比较不同工作簿中的两列

Question

I would appreciate if I can get help in creating this macro. I have two workbooks, and want to compare the specific column from 1st workbook, Ex: Column H with next work book, Ex: column A. After comparison highlight the matching cells in 1st workbook. I have tried below script for comparison, it is executing successfully, but not seeing any result.

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet, w(), i As Long
    Dim r As Range, myCol As String
    Set ws1 = ThisWorkbook.Sheets(1)
    Set ws2 = Workbooks("workbook.xlsx").Sheets(1)
    With CreateObject("VBScript.RegExp")
        .Pattern = "^([a-z]|[a-h][a-z]|[a-i][a-v])$"
        .IgnoreCase = True
        Do
            myCol = InputBox("Enter Column")
        Loop While Not .test(myCol)
    End With
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For Each r In ws1.Range(myCol & "1", ws1.Range(myCol & Rows.Count).End(xlUp))
            If Not IsEmpty(r) And Not .exists(r.Value) Then
                   ReDim w(0): w(0) = r.Row
                   .Add r.Value, w
            Else
                   w = .Item(r.Value)
                   ReDim Preserve w(UBound(w) + 1)
                   w(UBound(w)) = r.Row
                   .Item(r.Value) = w
            End If
        Next
        For Each r In ws2.Range("a1", ws2.Range("a" & Rows.Count).End(xlUp))
            If .exists(r.Value) Then
                For i = 0 To UBound(.Item(r.Value))
                     ws1.Range(myCol & .Item(r.Value)(i)).Offset(, 1).Resize(, 23).Value = _
                     r.Offset(, 1).Resize(, 23).Value
                Next
            End If
        Next
    End With
    Set ws1 = Nothing: Set ws2 = Nothing
End Sub

Answer 1

Try

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet, w(), i As Long, n As Integer
    Dim r As Range, myCol As String, wbname As String, msg As String
    
    Set ws1 = ThisWorkbook.Sheets(1)
   
    Dim myworkbooks As Variant, mycolors As Variant
    
    ' workbooks to compare
    myworkbooks = Array("Workbook1.xlsx", "Workbook2.xlsx", "Workbook3.xlsx")
    mycolors = Array(vbYellow, vbGreen, vbBlue)
    
    ' select column
    With CreateObject("VBScript.RegExp")
        .Pattern = "^([a-z]|[a-h][a-z]|[a-i][a-v])$"
        .IgnoreCase = True
        Do
            myCol = InputBox("Enter Column")
        Loop While Not .test(myCol)
    End With
    
    ' build dictionary
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        
        For Each r In ws1.Range(myCol & "1", ws1.Range(myCol & Rows.Count).End(xlUp))
            If IsEmpty(r) Then
              ' skip empty cells
            Else
                If Not .exists(r.Value) Then
                   ReDim w(0): w(0) = r.Row
                   .Add r.Value, w
                Else
                   w = .Item(r.Value)
                   ReDim Preserve w(UBound(w) + 1)
                   w(UBound(w)) = r.Row
                   .Item(r.Value) = w
                End If
            End If
        Next
                
        ' compare and highlight match
        For n = 0 To UBound(myworkbooks)
            Debug.Print "Opening " & myworkbooks(n)
            msg = msg & vbCrLf & myworkbooks(n)
            
            Set ws2 = Workbooks(myworkbooks(n)).Sheets(1)
        
            For Each r In ws2.Range("a1", ws2.Range("a" & Rows.Count).End(xlUp))
                If .exists(r.Value) Then
                    
                    For i = 0 To UBound(.Item(r.Value))
                         ws1.Range(myCol & .Item(r.Value)(i)).Interior.color = mycolors(n)
                    Next
                    
                End If
            Next r
        Next n
        
    End With
    Set ws1 = Nothing: Set ws2 = Nothing
    MsgBox "Completed scanning" & msg, vbInformation
End Sub