Compare two columns in different workbooks - excel

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