ルール表を用いたExcelVBAのチェック処理（chatgpt産）

Sub チェック処理()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("データ") ' シート名を変更してください

Dim lastRow As Long, lastCol As Long
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

' ヘッダを取得（列名 → 列番号のマッピング）
Dim colMap As Object
Set colMap = CreateObject("Scripting.Dictionary")

Dim j As Long
For j = 1 To lastCol
    colMap(ws.Cells(1, j).Value) = j
Next j

' ルール表のDictionary作成
Dim dictRules As Object
Set dictRules = CreateObject("Scripting.Dictionary")

' ルール表のデータ取得（ルールは "ルール" シートにあると仮定）
Dim wsRule As Worksheet
Set wsRule = ThisWorkbook.Sheets("ルール")

Dim ruleLastRow As Long
ruleLastRow = wsRule.Cells(Rows.Count, 1).End(xlUp).Row

Dim ruleNo As String, ruleCondition As String, ruleItem As String, ruleControl As String
For i = 2 To ruleLastRow
    ruleNo = wsRule.Cells(i, 1).Value
    ruleCondition = wsRule.Cells(i, 2).Value
    ruleItem = wsRule.Cells(i, 3).Value
    ruleControl = wsRule.Cells(i, 4).Value

    If Not dictRules.Exists(ruleNo) Then
        dictRules.Add ruleNo, CreateObject("Scripting.Dictionary")
    End If

    dictRules(ruleNo)(ruleItem) = Array(ruleCondition, ruleControl)
Next i

' チェック処理
Dim i As Long, key As String, targetColumn As Long
Dim errMsg As String
errMsg = ""

For i = 2 To lastRow
    Dim dataNo As String
    dataNo = ws.Cells(i, 1).Value

    ' ルールの適用チェック
    For Each key In dictRules.Keys
        If dataNo = key Or Left(dataNo, Len(key)) = key Then
            Dim ruleDict As Object
            Set ruleDict = dictRules(key)

            Dim targetItem As Variant
            For Each targetItem In ruleDict.Keys
                targetColumn = colMap(targetItem)
                Dim cellValue As Variant
                cellValue = ws.Cells(i, targetColumn).Value

                Dim ruleArr As Variant
                ruleArr = ruleDict(targetItem)

                Dim condition As String
                condition = ruleArr(0)
                Dim control As String
                control = ruleArr(1)

                ' 一致ルール
                If condition = "一致" And cellValue <> "" Then
                    If control = "入力不可" Then
                        errMsg = errMsg & "エラー: " & dataNo & " の " & targetItem & " は入力不可なのに値が入っています。" & vbCrLf
                    End If
                End If

                ' 不一致ルール
                If condition = "不一致" And cellValue = "" Then
                    If control = "入力必須" Then
                        errMsg = errMsg & "エラー: " & dataNo & " の " & targetItem & " は入力必須なのに空欄です。" & vbCrLf
                    End If
                End If
            Next targetItem
        End If
    Next key
Next i

' 結果出力
If errMsg <> "" Then
    MsgBox errMsg, vbExclamation, "チェックエラー"
Else
    MsgBox "全件チェック完了。エラーなし。", vbInformation, "チェック結果"
End If

End Sub