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

При запуске сценарияон копирует данные на основе ключа.Мой код работает для 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 в качестве ключа словаря и объедините несколько столбцов в массив, который будет сохранен как словарь. Item

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