ＶＢＡアクセルで一致性チェックツール作成

 

Private Sub btnRonRiMeiCheck_Click()
Dim tRow, pRow As Integer
Dim tblNum, apdNum As Integer
Dim afName, tblName, phName, lgName As String
Dim tblNames(50), apdName(2000) As String
Dim i, j As Integer

'ActionFrom項目一覧最終行を取得
pRow = 1
afName = "ActionFrom項目一覧"
Do While True
    With Worksheets(afName).Cells(pRow, 1)
    If .Value = "" Then
        Exit Do
    Else
        pRow = pRow + 1
    End If
    End With
Loop

'テーブル一覧取得
tblNum = 0
For Each ws In Worksheets
    pref = Left(ws.Name, 1)
    If pref = "T" Or pref = "M" Then
        tblNum = tblNum + 1
        tblNames(tblNum) = ws.Name
    End If
Next

 

'テーブル項目ループ
apdNum = 1
For i = 1 To tblNum
    tRow = 2
    tblName = tblNames(i)
    Do While True
       
        lgName = Worksheets(tblName).Cells(tRow, 2).Value
        phName = Worksheets(tblName).Cells(tRow, 6).Value
       
        If lgName = "" Then
            Exit Do
        Else
            If Worksheets(tblName).Cells(tRow, 7).Interior.Color = RGB(255, 0, 0) Then
               
                For j = 1 To pRow
                    If phName = Worksheets(afName).Cells(j, 2).Value Then
                        If lgName <> Worksheets(afName).Cells(j, 3).Value Then
                           
                            '論理名不一致
                            MsgBox tblName & ":" & tRow - 1 & "の" & lgName & "と" & afName & ":" & j & "の" & "論議名が不一致ですが、直して下さい。"
                            Exit Sub
                        End If
                    End If
                Next
            End If
           
            tRow = tRow + 1
        End If
    Loop
Next

MsgBox "論理名チェック完了しました、正常終了しました。"
End Sub