Excel VBA实现跨工作簿匹配列数据并复制至空白列

需求说明 #

本人拥有order和database两个工作簿，需编写VBA脚本：匹配两个工作簿中B列与G列的行数据，将order工作簿中的指定单元格内容复制到database工作簿的下一个空白列。

现有VBA代码 #

Sub macro1()

Dim w1 As Worksheet, w2 As Worksheet
Dim iLastRow As Long, r As Long
Dim dict As Object, key As String, ar
Set dict = CreateObject("Scripting.Dictionary")

' 从order工作表（itimat）构建查找字典
Set w2 = Workbooks("Itimat-Bestellung.xlsm").Worksheets("itimat")
iLastRow = w2.Cells(Rows.Count, "B").End(xlUp).Row
ar = w2.Range("B4:D" & iLastRow).Value2

For r = 1 To UBound(ar)
    key = ar(r, 1) & vbTab & ar(r, 2)
    If Len(key) > 1 Then ' 跳过空白行
        If dict.exists(key) Then
            MsgBox "发现重复键值: '" & key & "'", vbCritical, "行号: " & r
            Exit Sub
        Else
            dict.Add key, ar(r, 3)
        End If
    End If
Next

' 更新database工作表（datenbank）
Set w1 = Workbooks("Itimat-Bestellung.xlsm").Worksheets("datenbank")
iLastRow = w1.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To iLastRow
    key = w1.Cells(r, "A") & vbTab & w1.Cells(r, "B")
    If dict.exists(key) Then
        w1.Cells(r, "C") = dict(key)
    End If
Next
MsgBox "数据已保存至数据库工作表"
End Sub

辅助参考信息 #

工作表截图 #

数据示例 #

内容的提问来源于stack exchange，提问作者John Kater