如何通过VBA按员工ID对比员工数据工作簿并生成差异报告

核心优化逻辑 #

原代码按行顺序对比不符合员工随机排序的场景，且逐单元格读取效率极低。优化核心是用字典存储员工ID与行号的映射关系，实现O(1)速度匹配同ID员工，同时把数据加载到数组中对比，运行效率可提升数十倍。

具体修改步骤 #

• 修正原代码基础语法错误：变量类型定义错误（工作表对象应为Worksheet而非Workbooks）、全角符号替换为半角、补充未定义的工作簿变量声明
• 引入字典对象存储员工ID映射：先遍历其中一个工作表的D列（员工ID列），将ID作为Key、对应行号作为Value存入字典
• 按ID匹配员工后再对比字段：遍历另一个工作表的所有员工行，通过ID从字典中快速找到对应行，找不到的标记为「新增/离职」
• 字段对比逻辑优化：仅对匹配到的同ID员工逐列对比，有差异的单元格高亮，整行存在任意差异则「Change Information」列标Yes，否则标No
• 新增Physician字段重点标记：可单独对L列的差异设置更醒目的样式

修改后完整代码 #

Sub compare2Worksheets()
    ' 声明变量
    Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet
    Dim lastRowOld As Long, lastRowNew As Long, maxCol As Integer
    Dim arrOld, arrNew, idDict As Object
    Dim i As Long, j As Long, matchRow As Long, difference As Long
    Dim reportWb As Workbook, hasChange As Boolean, empId, nextRow As Long, myFileName As String
    
    ' 初始化字典（后期绑定，无需额外引用）
    Set idDict = CreateObject("Scripting.Dictionary")
    ' 此处修改为你的新旧表对应工作簿和工作表
    Set wsOld = ThisWorkbook.Worksheets("Data1") ' 旧版数据表
    Set wsNew = Workbooks("新版员工表.xlsx").Worksheets("Data2") ' 新版数据表，此处修改为你实际的新版工作簿名称
    Set reportWb = Workbooks.Add
    Set wsReport = reportWb.Worksheets(1)
    
    ' 获取新旧表有效范围，加载到数组提升对比速度
    With wsOld.UsedRange
        lastRowOld = .Rows.Count
        maxCol = .Columns.Count
        arrOld = .Value
    End With
    With wsNew.UsedRange
        lastRowNew = .Rows.Count
        If .Columns.Count > maxCol Then maxCol = .Columns.Count
        arrNew = .Value
    End With
    
    ' 先把新版的员工ID存入字典，key为ID，value为行号
    For i = 2 To lastRowNew ' 跳过表头行
        If Not idDict.exists(arrNew(i, 4)) Then ' D列是第4列，员工ID
            idDict(arrNew(i, 4)) = i
        End If
    Next i
    
    ' 初始化报告表头
    wsReport.Cells.Clear
    wsReport.Range("A1:L1") = Array("FirstName", "LastName", "DOB", "EmployeeID", "Address", "Emailadd", _
        "Mobilenumber", "DeptID", "DeptName", "Position", "Status", "Physician")
    wsReport.Range("M1") = "Change Information"
    wsReport.Range("A1:M1").Font.Bold = True
    
    ' 遍历旧表所有员工，按ID匹配对比
    difference = 0
    For i = 2 To lastRowOld ' 跳过表头
        hasChange = False
        empId = arrOld(i, 4)
        ' 查找新版中对应ID的行
        If idDict.exists(empId) Then
            matchRow = idDict(empId)
            ' 逐列对比字段
            For j = 1 To maxCol
                If arrOld(i, j) <> arrNew(matchRow, j) Then
                    ' 存在差异
                    difference = difference + 1
                    wsReport.Cells(i, j) = arrOld(i, j) & " <> " & arrNew(matchRow, j)
                    ' 高亮差异单元格
                    wsReport.Cells(i, j).Interior.Color = vbRed
                    wsReport.Cells(i, j).Font.Color = vbWhite
                    wsReport.Cells(i, j).Font.Bold = True
                    ' L列是Physician字段，额外加醒目标记
                    If j = 12 Then wsReport.Cells(i, j).Interior.Color = vbMagenta
                    hasChange = True
                Else
                    wsReport.Cells(i, j) = arrNew(matchRow, j)
                End If
            Next j
            ' 填写变更标记
            If hasChange Then
                wsReport.Cells(i, "M") = "Yes"
            Else
                wsReport.Cells(i, "M") = "No"
            End If
            ' 匹配过的ID从字典移除，剩下的就是旧表没有的新增员工
            idDict.Remove empId
        Else
            ' 旧表存在、新版不存在，标记为离职
            wsReport.Cells(i, "D") = empId
            wsReport.Cells(i, "M") = "已离职"
            wsReport.Rows(i).Interior.Color = vbYellow
        End If
    Next i
    
    ' 处理字典中剩余的ID：新版有、旧版没有的新增员工
    nextRow = lastRowOld + 1
    For Each empId In idDict.keys
        matchRow = idDict(empId)
        wsReport.Cells(nextRow, "D") = empId
        wsReport.Cells(nextRow, "M") = "新增"
        wsReport.Rows(nextRow).Interior.Color = vbGreen
        ' 填充新版员工信息
        For j = 1 To maxCol
            wsReport.Cells(nextRow, j) = arrNew(matchRow, j)
        Next j
        nextRow = nextRow + 1
    Next
    
    ' 调整格式保存
    If difference > 0 Or idDict.Count > 0 Then
        wsReport.Columns("A:M").ColumnWidth = 20
        myFileName = InputBox("请输入保存的文件名：")
        If myFileName <> "" Then
            reportWb.SaveAs Filename:=myFileName & ".xlsx"
        End If
    End If
    
    ' 释放对象
    Set idDict = Nothing
    Set wsOld = Nothing
    Set wsNew = Nothing
    Set wsReport = Nothing
    Set reportWb = Nothing
End Sub

使用注意事项 #

• 运行代码前请先打开旧版和新版两个员工工作簿，修改代码中Workbooks("新版员工表.xlsx")部分为你实际的新版工作簿文件名
• 如果员工ID列或者Physician字段的列位置有变动，对应修改代码中列号即可（D列是4，L列是12）
• 代码默认标记了离职、新增员工，不需要的话可以删除对应逻辑

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