[已解决]两张工作合并

清风竹影203

谢谢老师了

清风竹影203

frankzhang21 发表于 2018-7-7 10:11
哈哈半年多了，不知道你的问题解决了没有。

好久没写VBA了，现在都用R了

谢谢老师，但那个什么错误“6”溢出和错误"9"下标越界,还是会出现
愁死我了，请老师帮帮忙，有时出现，有时正常。
Option Explicit
Public Sub update()
    Dim arr(), brr(), crr(), drr(), d, i, k, n, p
    Set d = CreateObject("scripting.dictionary")
    Cells.Replace "#value!", ""
    arr = Sheet1.UsedRange.Offset(1)
    brr = Sheet2.UsedRange.Offset(1)
    ReDim drr(1 To UBound(brr), 1 To UBound(brr, 2))
    ReDim crr(1 To UBound(brr, 2))
    For i = 1 To UBound(brr, 1)
        For n = 1 To (UBound(brr, 2) - 1)
            crr(n) = brr(i, n + 1)
        Next n
        d(brr(i, 1)) = crr
        ReDim crr(1 To UBound(brr, 2) - 1)
    Next i
    For k = 1 To UBound(arr)
        If d.exists(arr(k, 1)) Then
            p = p + 1
            drr(p, 1) = k + 1
            For n = 2 To (UBound(brr, 2))
                drr(p, n) = d(arr(k, 1))(n - 1)
            Next n
        End If
    Next k
    With Sheet1
        For i = 1 To p
            For k = 2 To UBound(drr, 2)
                If drr(i, k) <> "" And .Cells(drr(i, 1), k) <> drr(i, k) Then
                    .Cells(drr(i, 1), k) = drr(i, k)
                    .Cells(drr(i, 1), k).Font.Color = 255
                End If
            Next
        Next
    End With
End Sub