Question

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

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

我通过以下代码完成了匹配值列：

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

快速与激情＆＃34;您希望大量使用数组和字典的代码，并将Excel工作表范围访问限制为最小值

因此，从我的上一个代码中获取以下代码，但限制excel表格可以访问初始数据读取和最终数据写入，这些都是在＃34;一次拍摄和＃34;模式（或接近）

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

Answer 2

我认为您不需要使用字典 - 您可以浏览Book1列A中的每个值，检查它是否存在于{{1}的范围内} Book2列，如果是，则可以移植其相应的值 - 如果不是，则将其添加到最后并将其关联的值移出。这是一个简单，动态的解决方案。

注意简单使用A返回行位置：

.Find

Excel VBA字典：如果数据与字典

2 个答案: