VBA需求：对比报表列差异后复制A列及相邻B列至新工作表

这是之前对比两报表A列找差异问题的跟进需求——原解决方案只能复制差异的A列单元格，现在需要基于A列的用户ID做对比，发现差异时同时复制对应的A列（用户ID）和B列（员工姓名）到新工作表，且不能复制整行。

原参考代码（Vityata提供） #

Public Sub FindDifferences()
    Dim firstRange As Range
    Dim secondRange As Range
    Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
    Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
    Dim wks3 As Worksheet: Set wks3 = Worksheets(3)
    Set firstRange = wks1.UsedRange
    Set secondRange = wks2.UsedRange
    Dim myCell As Range
    For Each myCell In firstRange
        If myCell <> secondRange.Range(myCell.Address) Then
            wks3.Range(myCell.Address) = myCell
        End If
    Next myCell
End Sub

你当前使用的代码 #

Public Sub FindDifferences()
    Dim firstRange As Range
    Dim secondRange As Range
    Dim myCell As Range
    Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
    'Find Removed Wintel Servers
    Set wks1 = ActiveWorkbook.Sheets("sh1")
    Set wks2 = ActiveWorkbook.Sheets("sh2")
    Set wks3 = ActiveWorkbook.Sheets("sh3")
    Set firstRange = Range(wks1.Range("A1"), wks1.Range("A" & Rows.Count).End(xlUp))
    Set secondRange = Range(wks2.Range("A1"), wks2.Range("A" & Rows.Count).End(xlUp))
    For Each myCell In secondRange
        If WorksheetFunction.CountIf(firstRange, myCell) = 0 Then
            myCell.Copy
            wks3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wks3.Cells(Rows.Count, 1).End(xlUp).PasteSpecial xlPasteFormats
        End If
    Next myCell
    wks3.Range("A1").Select
End Sub

修改后的代码（实现A、B列同时复制） #

Public Sub FindDifferences()
    Dim firstRange As Range
    Dim secondRange As Range
    Dim myCell As Range
    Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
    Dim targetRow As Long ' 记录新工作表的目标行
    
    'Find Removed Wintel Servers
    Set wks1 = ActiveWorkbook.Sheets("sh1")
    Set wks2 = ActiveWorkbook.Sheets("sh2")
    Set wks3 = ActiveWorkbook.Sheets("sh3")
    
    Set firstRange = wks1.Range("A1", wks1.Range("A" & Rows.Count).End(xlUp))
    Set secondRange = wks2.Range("A1", wks2.Range("A" & Rows.Count).End(xlUp))
    
    For Each myCell In secondRange
        ' 检查当前A列单元格是否在sh1的A列中不存在
        If WorksheetFunction.CountIf(firstRange, myCell) = 0 Then
            ' 获取新工作表中第一个空行的行号
            targetRow = wks3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            
            ' 复制当前单元格及相邻B列的内容和格式
            myCell.Resize(1, 2).Copy
            With wks3.Cells(targetRow, 1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
            Application.CutCopyMode = False ' 清除复制状态，避免保留虚线边框
        End If
    Next myCell
    
    wks3.Range("A1").Select
End Sub

关键修改说明 #

• 新增targetRow变量，提前获取新工作表的目标行，避免重复调用End(xlUp)，提升代码效率
• 使用myCell.Resize(1, 2)选中当前A列单元格和右侧的B列单元格，一次性完成两列内容的复制
• 粘贴时直接定位到目标行的A列，同时完成值和格式的粘贴，简化操作流程
• 加入Application.CutCopyMode = False清除复制状态，避免Excel界面保留复制的虚线边框

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