vba - Excel VBA 字典 : add matching criteria if the data doesn't match with dictionary

Question

几乎在这一天，我一直在努力寻找一种将匹配标准添加到另一个工作簿的方法，但我还没有找到任何方法。示例场景是
下面，我有两个工作簿(workbookA 和 workbookB)，每个工作簿都有自己的“国家”和“值(value)”列表。请参阅下面的示例表。

Workbook("WorkA").Sheet1                  Workbook("workB").Sheet1Country   Value                           Country     Value           A          10                             BB          15                             DC          20                             ED          25                             AE          30F          35

I finished matching value column by the following code:

Sub Test_match_fill_data()

Dim Dict As Object
Dim key As Variant
Dim aCell, bCell As Range
Dim i, j As Long
Dim w1, w2 As Worksheet


    Set Dict = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workA").Sheets("Sheet1")
    Set w2 = Workbooks("workB").Sheets("Sheet1")


    i = w1.Cells(w1.Rows.Count, 1).End(xlUp).row


    For Each aCell In w1.Range("A6:A" & i)
        If Not Dict.exists(aCell.Value) Then 
            Dict.Add aCell.Value, aCell.Offset(0, 2).Value
        End If
    Next

    j = w2.Cells(w2.Rows.Count, 1).End(xlUp).row

    For Each bCell In w2.Range("A6:A" & j)
        For Each key In Dict
            If bCell.Value = key Then
                bCell.Offset(0, 2).Value = Dict(key)
            End If
        Next
    Next

End Sub

我想做的是从“workA”中添加一些缺失的国家(在这种情况下是国家“C”和“F”)，然后再次重做匹配过程以收集所有数据。复制和粘贴解决方案不适合我的情况，因为我必须收集时间序列数据(贸易数据)，而且我感兴趣的国家可能会在几个月内与新的合作伙伴进行贸易。我曾尝试在几个网站上对此进行研究，并深入研究并使用其他人的代码调整了我的代码，如下链接:
Dictionary add if doesn't exist , Looping Through EXCEL VBA Dictionary , Optimise compare and match method using scripting.dictionary in VBA , A 'flexible' VBA approach to lookups using arrays, scripting dictionary

任何潜在的大师可以建议我解决这类问题的解决方案或想法吗？如果您能解释代码背后的原因或我犯的任何错误，那就太好了。

谢谢!

Answer 1

对您的代码进行最少的更改:

Sub Test_match_fill_data()
    Dim Dict As Object
    Dim key As Variant
    Dim aCell As Range, bCell As Range
    Dim i As Long, j As Long
    Dim w1 As Worksheet, w2 As Worksheet

    Set Dict = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workA").Sheets("Sheet1")
    Set w2 = Workbooks("workB").Sheets("Sheet1")

    i = w1.Cells(w1.Rows.Count, 1).End(xlUp).row

    For Each aCell In w1.Range("A6:A" & i)
        Dict(aCell.Value) = aCell.Offset(0, 2).Value
    Next

    j = w2.Cells(w2.Rows.Count, 1).End(xlUp).row

    For Each bCell In w2.Range("A6:A" & j)
        If Dict.Exists(bCell.Value) Then
            bCell.Offset(0, 2).Value = Dict(bCell.Value)
            Dict.Remove bCell.Value
        End If
    Next

    For Each key In Dict
        With w2.Cells(w2.Rows.Count, 1).End(xlUp).Offset(1)
             .Value = key
            .Offset(,2) = Dict(key)
         End With
    Next
End Sub

虽然它的稍微更精简的版本可能如下:

Sub Test_match_fill_data()
    Dim Dict As Object
    Dim key As Variant
    Dim cell As Range

    Set Dict = CreateObject("Scripting.Dictionary")
    With Workbooks("workA").Sheets("Sheet1")
        For Each cell In .Range("A6", .Cells(.Rows.count, 1).End(xlUp))
            Dict(cell.Value) = cell.Offset(0, 2).Value
        Next
    End With

    With Workbooks("workB").Sheets("Sheet1")
        For Each cell In .Range("A6", .Cells(Rows.count, 1).End(xlUp))
            If Dict.Exists(cell.Value) Then
                cell.Offset(0, 2).Value = Dict(cell.Value)
                Dict.Remove cell.Value
            End If
        Next
        For Each key In Dict
            With .Cells(.Rows.count, 1).End(xlUp).Offset(1)
                 .Value = key
                .Offset(, 2) = Dict(key)
             End With
        Next
    End With
End Sub

对于“速度与激情”代码，您需要大量使用数组和字典，并将 excel 工作表范围访问限制在最低限度

所以以下代码是从我的上一个代码中获得的，但限制了对初始数据读取和最终数据写入的 excel 工作表范围访问，无论是在“单次”模式下(或几乎)

Sub Test_match_fill_data()
    Dim Dict As Object
    Dim iItem As Long
    Dim workACountries As Variant, workAValues As Variant
    Dim workBCountries As Variant, workBValues As Variant

    With Workbooks("workA").Sheets("Sheet1")
        workACountries = .Range("A6", .Cells(.Rows.count, 1).End(xlUp)).Value
        workAValues = .Range("C6:C" & .Cells(.Rows.count, 1).End(xlUp).Row).Value
    End With

    Set Dict = CreateObject("Scripting.Dictionary")
    For iItem = 1 To UBound(workACountries)
        Dict(workACountries(iItem, 1)) = workAValues(iItem, 1)
    Next

    With Workbooks("workB").Sheets("Sheet1")
        workBCountries = .Range("A6", .Cells(.Rows.count, 1).End(xlUp)).Value
        workBValues = .Range("C6:C" & .Cells(.Rows.count, 1).End(xlUp).Row).Value
    End With

    For iItem = 1 To UBound(workBCountries)
        If Dict.Exists(workBCountries(iItem, 1)) Then
            workBValues(iItem, 1) = Dict(workBCountries(iItem, 1))
            Dict.Remove workBCountries(iItem, 1)
        End If
    Next

    With Workbooks("workB").Sheets("Sheet1")
        .Range("A6").Resize(UBound(workBCountries)).Value = workBCountries
        .Range("C6").Resize(UBound(workBCountries)).Value = workBValues

        .Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(Dict.count).Value = Application.Transpose(Dict.Keys)
        .Cells(.Rows.count, 3).End(xlUp).Offset(1).Resize(Dict.count).Value = Application.Transpose(Dict.Items)
    End With
End Sub