VBA需求：仅复制Rufus Unal表中A列未存在于UTM表的数据

• 我是VBA新手，现有代码能把「Rufus Unal」工作表的数据复制到「UTM Unal Cash Report」工作表，但现在需要改代码，只复制A列（带唯一参考标识）在目标表里没有的数据，并且追加到目标表的最后一行。
• 之前试过先全复制再删重复项，没成功，求帮忙解决。

Sub RunUac()

Dim LR1 As Long
Dim LR2 As Long
Dim LR3 As Long
Dim LR4 As Long
Dim wb1 As Workbook
Dim wb2 As Workbook
Set wb1 = ThisWorkbook
Dim cell As Range

Application.ScreenUpdating = False

Worksheets("Rufus Unal").Visible = True


Workbooks.Open "K:\Finance\Unallocated Cash\Reconciliations\Templates/Rufus_Unal.xlsx", ReadOnly:=True


Workbooks("Rufus_Unal.xlsx").Activate

Sheets("UCRR001x").Activate

LR1 = Cells(Rows.Count, "a").End(xlUp).Row

Range("A2:O" & LR1).Copy

    wb1.Activate
    Sheets("Rufus Unal").Select
    Range("A11").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
        
   
Workbooks("Rufus_Unal.xlsx").Activate

ActiveWorkbook.Close SaveChanges:=False

Sheets("GL").Select
    Range("Sheet16[[#Headers],[Accnt.]]").Select
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    
Sheets("Rufus Unal").Select
    LR1 = Cells(Rows.Count, "b").End(xlUp).Row

Range("A11:A" & LR1).Copy
    Sheets("UTM Unal Cash Report").Select
    Range("A10").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

Sheets("Rufus Unal").Select
Range("I11:I" & LR1).Copy
    Sheets("UTM Unal Cash Report").Select
    Range("B10").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
Sheets("Rufus Unal").Select
Range("D11:D" & LR1).Copy
    Sheets("UTM Unal Cash Report").Select
    Range("C10").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

Sheets("Rufus Unal").Select
Range("B11:B" & LR1).Copy
    Sheets("UTM Unal Cash Report").Select
    Range("D10").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

Sheets("Rufus Unal").Select
Range("C11:C" & LR1).Copy
    Sheets("UTM Unal Cash Report").Select
    Range("E10").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    

Sheets("Sign Off Form").Select
     Range("C31").Value = Application.UserName
     Application.ScreenUpdating = True

End Sub

解决思路：先把目标表A列已有的唯一标识存到集合里（集合的键不能重复，刚好用来判断是否存在），然后遍历源表每一行，检查A列值如果不在集合里，就把对应列的数据复制到目标表的最后一行。

修改后的代码如下：

Sub RunUac()
    Dim LR1 As Long, LR_Target As Long
    Dim wb1 As Workbook, wb2 As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim uniqueIDs As New Collection
    Dim i As Long
    Dim id As Variant
    
    Application.ScreenUpdating = False
    
    ' 定义工作表对象，避免频繁切换激活
    Set wb1 = ThisWorkbook
    Set wsSource = wb1.Worksheets("Rufus Unal")
    Set wsTarget = wb1.Worksheets("UTM Unal Cash Report")
    
    ' 第一步：把目标表已有的A列唯一ID存入集合
    LR_Target = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row
    On Error Resume Next ' 重复ID会报错，忽略这个错误
    For i = 10 To LR_Target ' 目标表数据从A10开始
        id = wsTarget.Cells(i, "A").Value
        If id <> "" Then uniqueIDs.Add id, Key:=CStr(id)
    Next i
    On Error GoTo 0 ' 恢复正常错误处理
    
    ' 第二步：打开外部文件，更新Rufus Unal表的数据
    wsSource.Visible = True
    Set wb2 = Workbooks.Open("K:\Finance\Unallocated Cash\Reconciliations\Templates/Rufus_Unal.xlsx", ReadOnly:=True)
    With wb2.Sheets("UCRR001x")
        .Range("A2:O" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy
    End With
    wsSource.Range("A11").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    wb2.Close SaveChanges:=False
    
    ' 第三步：刷新GL表的查询数据
    wb1.Worksheets("GL").ListObjects("Sheet16").QueryTable.Refresh BackgroundQuery:=False
    
    ' 第四步：遍历源表，复制目标表没有的新记录
    LR1 = wsSource.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 11 To LR1 ' 源表数据从第11行开始
        id = wsSource.Cells(i, "A").Value
        If id <> "" Then
            ' 尝试把ID加入集合，如果成功说明是新ID
            On Error Resume Next
            uniqueIDs.Add id, Key:=CStr(id)
            If Err.Number = 0 Then
                ' 获取目标表最后一行的下一行
                LR_Target = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
                ' 复制对应列的数据
                wsTarget.Cells(LR_Target, "A").Value = wsSource.Cells(i, "A").Value
                wsTarget.Cells(LR_Target, "B").Value = wsSource.Cells(i, "I").Value
                wsTarget.Cells(LR_Target, "C").Value = wsSource.Cells(i, "D").Value
                wsTarget.Cells(LR_Target, "D").Value = wsSource.Cells(i, "B").Value
                wsTarget.Cells(LR_Target, "E").Value = wsSource.Cells(i, "C").Value
            End If
            On Error GoTo 0
        End If
    Next i
    
    ' 第五步：更新签名
    wb1.Worksheets("Sign Off Form").Range("C31").Value = Application.UserName
    Application.ScreenUpdating = True
End Sub

代码说明 #

• 用Collection存目标表的ID，快速判断是否重复，比事后删重复项更精准高效。
• 去掉了原代码里一堆的Activate/Select操作，直接用工作表对象操作，减少出错概率，运行速度也更快。
• 逐行检查源表的ID，只复制目标表没有的新数据到最后一行，完全满足需求。

内容的提问来源于stack exchange，提问作者mikchadd