Excel VBA字典：如果数据不符合'；与词典不符

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

Workbook("WorkA").Sheet1 Workbook("workB").Sheet1 Country Value Country Value A 10 B B 15 D C 20 E D 25 A E 30 F 35 我想做的是从“workA”中添加一些缺少的国家（在本例中是国家“C”和“F”），然后再次重复匹配过程以收集所有数据。复制粘贴解决方案不适合我的情况，因为我必须收集时间序列数据（贸易数据），而且可能有几个月我感兴趣的国家将与新的合作伙伴进行贸易。我曾尝试在多个网站上对此进行研究，并通过以下链接深入并调整了我的代码与其他人的代码： ,

有没有哪位潜在的大师能为我提出解决这类问题的方案或想法？如果你能解释一下代码背后的原因或者我犯的任何错误，那就太好了

---

谢谢大家!

我认为你不需要为此使用字典-你可以检查

Book1

，column

a

中的每个值，检查它是否存在于

Book2

column

a

中的范围内，如果存在，你可以移植到它对应的值上-如果没有，则将它添加到末尾并将其关联的值带过来。这是一个简单、动态的解决方案

注意

的简单用法。查找
返回行位置：

Sub Test_match_fill_data()

Dim aCell
Dim i, j As Long, keyrow As Long
Dim w1, w2 As Worksheet

Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet1")

i = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
j = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row

For Each aCell In w1.Range("A2:A" & i)
    On Error Resume Next
    keyrow = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
    On Error GoTo 0

    If keyrow = 0 Then
        w2.Range("A" & j + 1).Value = aCell
        w2.Range("B" & j + 1).Value = aCell.Offset(0, 1).Value
        j = j + 1
    Else
        w2.Range("B" & keyrow).Value = aCell.Offset(0, 1).Value
    End If

    keyrow = 0
Next

End Sub

只需对代码进行最小的更改：

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工作表的访问范围限制为初始数据读取和最终数据写入，这两种方式都是“一次性”模式（或接近）

如果您只是复制粘贴它，顺序会有所不同-当这发现
w2
中不存在的第一条记录时，它被添加到底部，其值被带过来。@DisplayName Oops，我粘贴了错误的图像！谢谢你注意到hi@dwirony，谢谢你的建议。由于我是一个缺乏VBA编码经验的初学者，我无法生成那种动态解决方案。老实说，我更喜欢你的代码而不是我的代码，因为它简单，易于重新访问，并且对即将到来的新数据进行了良好的组织。很抱歉没有给你一个正确的标记作为我关于VBA字典的标题。感谢您分享您的知识，并教我一个简单的动态解决方案。如果有机会，我一定会将您的代码应用到我的工作中：）Hi@DisplayName，首先感谢您的帮助和及时回复。在我尝试使用你的代码后，我发现了一个很小的错误。在不进行任何编辑的情况下，您的代码将在普通国家/地区返回空白，但会添加缺少的国家/地区及其值。这是我的错误，我没有解释清楚。我真正想要的是来自共同国家和缺失国家的数据。不过，我已经把你的代码和我的代码结合起来了，到目前为止，它运行得很好。再次感谢你的建议，我非常感激：）不客气。然后你可以考虑把答案标记为“接受”。非常感谢。至于你所说的“微小错误”，请考虑我从代码中采用了<代码>偏移（2）<代码>，所以它从“C”栏中读取“值”，即“国家”栏右边的两列（列A）。基于这个假设，我根据您的数据测试了我的代码，它成功了。我可以征求您的意见吗？我是应该使用这个字典脚本，还是使用@dwirony？发布的动态解决方案，如下所示？。我的条件是我想尽快处理这些文件，因为它们有大量的文件等待处理。我不知道哪种解决方案需要我更多的时间。对这件事有什么意见吗？好吧，两个都试试！但大家都知道，dicts和array方法比工作表单元格读写速度快得多，这是我对这方面的最新认识。如果是这样，让我两个都试试。再次感谢您的帮助和意见。干杯D
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

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