VBA 重複項目チェックツール作成(二)

 

Private Sub btnKouMoKuCheck_Click()
Dim pRow As Integer
Dim afName, lgNameStart, lgName, outPutInformation As String
Dim i As Integer
Dim j As Integer
Dim vntFileName As Variant
Dim vntGetFileName As Variant

'ファイルを開くダイアログを開きます
vntFileName = _
    Application.GetOpenFilename( _
         FileFilter:="エクセルファイル(*.xlsx),*.xlsx" & _
                     ",CSVファイル(*.csv),*.csv" _
       , FilterIndex:=1 _
       , Title:="開けゴマ" _
       , MultiSelect:=True _
        )

'vntFileName = _
    'Application.GetOpenFilename( _
         FileFilter:="エクセルファイル(*.xlsx),*.xlsx" & _
                     ",CSVファイル(*.csv),*.csv" _
       , FilterIndex:=1 _
       , Title:="開けゴマ" _
       , MultiSelect:=True _
        )

'ファイルが選択されているとき(vntFileNameが配列型)は
'選択した全てのファイルをWorkbooks.Openメソッドを使い開きます。
If IsArray(vntFileName) Then
   For Each vntGetFileName In vntFileName
       Workbooks.Open vntGetFileName
      
       '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
       
        For i = 1 To pRow
            lgNameStart = Worksheets(afName).Cells(i, 2)
            For j = i + 1 To pRow
                lgName = Worksheets(afName).Cells(j, 2)
               
                '重複項目がある
                If lgNameStart = lgName Then
                    outPutInformation = "ワークブック:" & vntGetFileName & "のワークシート:" & afName & i & "の" & lgNameStart & "と" & j & "重複しています、直してください。"
                Else
                '重複項目がない
                    j = j + 1
                End If
            Next
       
            i = i + 1
        Next
      
       Workbooks.Close
   Next
End If

If Len(outPutInformation) > 0 Then
    MsgBox outPutInformation
Else
    MsgBox "重複項目がありません、チェック正常終了"
End If
   
End Sub