excel - VBA查找和替换不适用于所有列

Question

我正在使用一段循环通过 Excel 工作表的代码，使用其中的键将另一组数据复制到其中。两个数据集(数据集 A 到数据集 B)如下所示:

数据集 A:

Key  Val1  Val2  Val3
123  yes   up    right
324  no    down  right
314  no    up    left

数据集 B:

Key  Val1  Val2  Val3
123
314
324

当脚本运行时，它会根据 Key 复制数据。我的代码适用于 Val1 和 Val2，但只会导致 Val3 出现空白条目，这是意外且不需要的。我的代码如下:

    Sub copyData()
    Dim i As Long, arr As Variant, dict As Object

    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = vbTextCompare

    With Worksheets("COMBINED")
        'put combined!a:d into a variant array
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
        'loop through array and build dictionary keys from combined!a:a, dictionary item from rows b:d
        For i = LBound(arr, 1) To UBound(arr, 1)
            dict.Item(arr(i, 1)) = arr(i, 2)
            dict.Item(arr(i, 2)) = arr(i, 3)
            dict.Item(arr(1, 3)) = arr(1, 4)
        Next i
    End With

    With Worksheets("All SAMs Backlog")
        arr = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 3)).Value2
        'loop through array and if c:c matches combined!a:a then put combined!b:b into d:d
        For i = LBound(arr, 1) To UBound(arr, 1)
            If dict.exists(arr(i, 1)) Then
                arr(i, 2) = dict.Item(arr(i, 1))
                arr(i, 3) = dict.Item(arr(i, 2))
                arr(i, 4) = dict.Item(arr(i, 3))
            Else
                arr(i, 2) = vbNullString
                arr(i, 3) = vbNullString
                arr(i, 4) = vbNullString
            End If
        Next i
        'put populated array back into c3 (resized by rows and columns)
        .Cells(3, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

    MsgBox ("done")

End Sub

任何帮助表示赞赏。

Answer 1

使用组合列A作为字典键，将多列组合成一个数组存储为字典项

Sub tranferData()
    Dim i As Long, arr As Variant, dict As Object

    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = vbTextCompare

    With Worksheets("COMBINED")
        'put combined!a:d into a variant array
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
        'loop through array and build dictionary keys from combined!a:a, dictionary item from rows b:d
        For i = LBound(arr, 1) To UBound(arr, 1)
            'add key and multiple items as array
            If not dict.exists(arr(i, 1)) Then _
              dict.Add Key:=arr(i, 1), Item:=Array(arr(i, 2), arr(i, 3), arr(i, 4))
        Next i
    End With

    With Worksheets("All SAMs Backlog")
        arr = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 3)).Value2
        'loop through array and if c:c matches combined!a:a then put combined!b:d into d:f
        For i = LBound(arr, 1) To UBound(arr, 1)
            If dict.exists(arr(i, 1)) Then
                arr(i, 2) = dict.Item(arr(i, 1))(0)
                arr(i, 3) = dict.Item(arr(i, 1))(1)
                arr(i, 4) = dict.Item(arr(i, 1))(2)
            Else
                arr(i, 2) = vbNullString
                arr(i, 3) = vbNullString
                arr(i, 4) = vbNullString
            End If
        Next i
        'put populated array back into c3 (resized by rows and columns)
        .Cells(3, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

    MsgBox ("done")

End Sub