如果能在创建此宏时获得帮助,我将不胜感激。我有两个工作簿,并且想要比较第一个工作簿中的特定列,例如:H列与下一个工作簿中的特定列,例如:A列。比较之后,突出显示第一个工作簿中的匹配单元格。我已尝试使用以下脚本进行比较,它已成功执行,但未看到任何结果。
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
答案 0 :(得分:0)
尝试
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