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

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

数据集A:

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

Dataset 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

如有任何帮助,我们将不胜感激。