比较工作簿并生成带有突出显示的差异和附加列的报告

Question

我有两本巨大的（新旧）年度员工数据工作簿，并试图进行比较。每个工作簿都有相同的标题，员工的顺序是随机的。 这是我想要完成的任务：

1. 使用员工 ID（在 D 列中）作为参考，并比较他们是否更改了信息，特别是医师（在 L 列中）。
2. 生成报告突出显示不同的单元格并添加列（更改信息“是/否”），无论是否有更改。

问题： 此代码仅逐个单元格比较（花费大量时间）而不是每个员工 ID 我如何在此处插入员工 ID 的循环？我是VBA的新手。关于我应该如何去做的任何指导？谢谢。

Sub compare2Worksheets()
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Dim ws1 As Workbooks
Dim ws2 As Workbooks


Set report = Workbooks.Add

'range of Data1
Set ws1 = ThisWorkbook.Worksheets(“Data1”)
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With

'range of Data2
Set ws2 = myworkbook.Worksheets(“Data2”)
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With


maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col

'generate report
report.Worksheets(“Sheet1”).Activate
Cells.Clear
Range(“A1”) = “FirstName”
Range(“B1”) = “LastName”
Range(“C1”) = “DOB”
Range(“D1”) = “EmployeeID”
Range(“E1”) = “Address”
Range(“F1”) = “Emailadd”
Range(“G1”) = “Mobilenumber”
Range(“H1”) = “DeptID”
Range(“I1”) = “DeptName”
Range(“J1”) = “Position”
Range(“K1”) = “Status”
Range(“L1”) = “Physician”
Range(“M1”) = “Change InformationY / N”
erow = Data1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row

'look for differences 
difference = 0
For col = 1 To maxcol
    For row = 1 To maxrow
    colval1 = ws1.Cells(row, col)
    colval2 = ws2.Cells(row, col)
        If colval1 <> colval2 Then
        difference = difference + 1
        'not matched display and highlight
        Cells(row, col) = colval1 & “ <> ” & colval2
        Cells(row, col).Interior.Color = 255
        Cells(row, col).Font.ColorIndex = 2
        Cells(row, col).Font.Bold = True
        'to update “Change InformationY / N”
        Cells(row + 1, 13).Value = "Yes"
        Else
        Cells(row, col) = colval2
        Cells(row + 1, 13).Value = "No"
        End If
Next row
Next col

'saving report
If difference > 0 Then
Columns("A:B").ColumnWidth = 25
myfilename = InputBox("Enter Filename")
myfilename = myfilename & “.xlsx”
ActiveWorkbook.SaveAs Filename:=myfilename
End If

End Sub

Answer 1

我会在这里做以下事情：

首先，我会为 EmployeeID 和我在两张表中找到的行创建一个数组。

为此，我需要声明一个 RecordType（必须在模块的开头定义，而不是在过程中！） 我假设您要处理的员工少于 1024 人，如果更多，只需在 Dim-Statement 中使用更高的值。 我还假设 Employee-Id 是一个字符串，否则你必须使用 'Long' 或 'Integer' 来代替

Type EmpRowRec
   EmpId as string
   Row1 as Long
   Row2 as Long
End Type
Dim EmpRowArr(1 to 1024) as EmpRowRec, EmpRowCnt as integer

然后我会浏览两张表并搜索包含员工数据的行：

Dim CurRow as long, CurEmpRow as integer,EmpRowOut as integer
…
EmpRowCnt=0
For CurRow = 2 to ws1Row 
   Colval1=ws1.cells(currow,4).value
   EmpRowCnt=EmpRowCnt+1
   EmpRowArr(EmpRowCnt).EmpId=colval1
   EmpRowArr(EmpRowCnt).row1=CurRow
Next CurRow
For CurRow = 2 to ws2Row 
   Colval1=ws2.cells(currow,4).value
   EmpRowOut=0
   For CurEmpRow=1 to EmpRowCnt
      If EmpRowArr(CurEmpRow).EmpId=ColVal1 then EmpRowOut=0:Exit For
   Next CurEmpRow
   If EmpRowOut=0 then ' Employee is only in sheet 2
      EmpRowCnt=EmpRowCnt+1
      EmpRowArr(EmpRowCnt).EmpId=colval1
      EmpRowArr(EmpRowCnt).row2=CurRow
   else
      EmpRowArr(EmpRowOut).row2=CurRow
   End If
Next CurRow

现在您可以遍历数组并创建报告：

Currow =1 'You already copied the head values
For CurEmpRow=1 to EmpRowCnt
   with EmpRowArr(CurEmpRow)
      If (.row1>0) and (.row2>0) then 'your result will show only employees in both sheets
         Currow=currow+1
         For col=1 to maxcol
            Colval1=ws1.cells(.row1,col).value
            Colval2=ws1.cells(.row2,col).value
            Report.cells(currow,col).value=colval1
            If colval1<>colval2 then report.cells(currow,col).interior.color=rgb(255,200,200)
         Next col
      End if
   End with
Next CurEmpRow

此方法将向您展示解决此类问题的通用方法（我必须经常处理）。为了确保适应，例如如何处理只出现在一张表中的员工，需要标记具有低或高影响的更改，但在这里我无法帮助您，因为我不知道您的确切要求。

由于我只用word写了这段文字，我无法在VBA下测试片段，所以可能会出现一些小错误。请尝试修复它。

Answer 2

这是符合您逻辑的代码：

Type EmpRowRec
   EmpId As String
   Row1 As Long
   Row2 As Long
End Type

Sub compare2Worksheets()
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Dim CurRow As Long, CurEmpRow As Integer, EmpRowOut As Integer
Dim wbkA As Workbook, wbkB As Workbook
Dim EmpRowArr(1 To 1024) As EmpRowRec, EmpRowCnt As Integer

'get worksheets from the workbooks
Set wbkA = Workbooks("Data1")
Set ws1 = wbkA.Worksheets("Data1")
'range of Data1
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With

Set wbkB = Workbooks("Data2")
Set ws2 = wbkB.Worksheets("Data2")
'range of Data2
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With

maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col

'generate report workbook
Set report = Workbooks.Add
report.Worksheets("Sheet1").Activate
Cells.Clear
Range(“A1”) = “FirstName”
Range(“B1”) = “LastName”
Range(“C1”) = “DOB”
Range(“D1”) = “EmployeeID”
Range(“E1”) = “Address”
Range(“F1”) = “Emailadd”
Range(“G1”) = “Mobilenumber”
Range(“H1”) = “DeptID”
Range(“I1”) = “DeptName”
Range(“J1”) = “Position”
Range(“K1”) = “Status”
Range(“L1”) = “Physician”
Range(“M1”) = “Change InformationY / N”
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row

'go through both sheets and search for the row with the data for an employee
EmpRowCnt = 0
For CurRow = 2 To maxrow  'ws1row
   colval1 = ws1.Cells(CurRow, 4).Value
   EmpRowCnt = EmpRowCnt + 1
   EmpRowArr(EmpRowCnt).EmpId = colval1
   EmpRowArr(EmpRowCnt).Row1 = CurRow
Next CurRow
For CurRow = 2 To maxrow  'ws2row
   colval1 = ws2.Cells(CurRow, 4).Value
   EmpRowOut = 0
   For CurEmpRow = 1 To EmpRowCnt
      If EmpRowArr(CurEmpRow).EmpId = colval1 Then EmpRowOut = 0: Exit For
   Next CurEmpRow
   If EmpRowOut = 0 Then ' Employee is only in sheet 2
      EmpRowCnt = EmpRowCnt + 1
      EmpRowArr(EmpRowCnt).EmpId = colval1
      EmpRowArr(EmpRowCnt).Row2 = CurRow
   Else
      EmpRowArr(EmpRowOut).Row2 = CurRow
   End If
Next CurRow

'go through the array and create your report

CurRow = 1 'You already copied the head values
For CurEmpRow = 1 To EmpRowCnt
   With EmpRowArr(CurEmpRow)
      If (.Row1 > 0) And (.Row2 > 0) Then 'your result will show only employees in both sheets
         CurRow = CurRow + 1
         For col = 1 To maxcol
            colval1 = ws1.Cells(.Row1, col).Value
            colval2 = ws1.Cells(.Row2, col).Value
            report.Cells(CurRow, col).Value = colval1
            If colval1 <> colval2 Then report.Cells(CurRow, col).Interior.Color = RGB(255, 200, 200)
         Next col
      End If
   End With
Next CurEmpRow

If CurRow > 0 Then
Columns("A:Y").ColumnWidth = 25
myfilename = InputBox("Enter Filename")
myfilename = myfilename & “.xlsx”
ActiveWorkbook.SaveAs Filename:=myfilename
End If

End Sub

Answer 3

使用字典作为旧数据表上每个 ID 的行号的查找表。然后向下扫描新工作表，比较具有相同 ID 的行。出现在新工作表上但不在旧工作表上的 ID 被标记为“已添加”。那些在旧表上但不在新表上的被标记为“已删除”。

Option Explicit
Sub compare2Worksheets()

    ' config
    Const COL_ID = "D"
    Const COLS = 12 ' header col A to L
   
    Dim wb1 As Workbook, wb2 As Workbook, wbRep As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, wsRep As Worksheet
    Dim LastRow As Long, c As Long, i As Long, r As Long, n As Long
    Dim bDiff As Boolean, t0 As Single
    t0 = Timer
    
    Dim dict As Object, key As String
    Set dict = CreateObject("Scripting.Dictionary")
     
    'range of Data1
    Set wb1 = ThisWorkbook
    Set wb2 = ThisWorkbook ' or other
    Set ws1 = wb1.Sheets("Data1") ' old data
    Set ws2 = wb2.Sheets("Data2") ' new data

    ' build lookup from data1
    With ws1
        LastRow = .Cells(.Rows.Count, COL_ID).End(xlUp).row
        For i = 2 To LastRow
            key = Trim(.Cells(i, COL_ID))
            If dict.exists(key) Then
                MsgBox "Duplicate ID " & key, vbCritical, .Name & " Row " & i
                Exit Sub
            ElseIf Len(key) > 0 Then
                dict.Add key, i
            End If
        Next
    End With
    
    ' format report sheet
    Set wbRep = Workbooks.Add(1)
    Set wsRep = wbRep.Sheets(1)
    wsRep.Name = "Created " & Format(Now, "YYYY-MM-DD HHMMSS")
    ws1.Range("A1").Resize(, COLS).Copy wsRep.Range("A1")
    wsRep.Cells(1, COLS + 1) = "Change InformationY / N"

    ' copare data2 new data to data1 old data
    ' copy diff to report
    Application.ScreenUpdating = False
    With ws2
        LastRow = .Cells(.Rows.Count, COL_ID).End(xlUp).row
        For i = 2 To LastRow
            key = Trim(.Cells(i, COL_ID))
            wsRep.Cells(i, COL_ID) = key
            If dict.exists(key) Then

                 r = dict(key)
                 dict.Remove key ' remove

                 ' check columns in row
                 bDiff = False
                 For c = 1 To COLS
                     If .Cells(i, c) <> ws1.Cells(r, c) Then
                         With wsRep.Cells(i, c)
                              .Value = ws2.Cells(i, c) & "<>" & ws1.Cells(r, c)
                              .Interior.Color = 255
                              .Font.ColorIndex = 2
                              .Font.Bold = True
                         End With
                         bDiff = True
                     End If
                 Next
                 If bDiff Then
                      wsRep.Cells(i, COLS + 1) = "Yes"
                      n = n + 1
                 Else
                      wsRep.Cells(i, COLS + 1) = "No"
                 End If
            Else
                ' copy all
                .Cells(i, 1).Resize(, COLS).Copy wsRep.Cells(i, 1)
                wsRep.Cells(i, COLS + 1) = "Added"
                n = n + 1
            End If
        Next
    End With
 
    ' keys remaining
    Dim k
    With ws1
        For Each k In dict.keys
            r = dict(k)
            .Cells(r, 1).Resize(, COLS).Copy wsRep.Cells(i, 1)
            wsRep.Cells(i, COL_ID) = k
            wsRep.Cells(i, COLS + 1) = "Deleted"
            i = i + 1
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = True

    Dim s As String, yn
    wsRep.Columns("A:M").AutoFit
    yn = MsgBox(n & " lines differ, save report Y/N ?", vbYesNo, _
               Format(Timer - t0, "0.0 secs"))

    If yn = vbYes Then
        s = InputBox("Enter Filename")
        wbRep.SaveAs Filename:=s & ".xlsx"
    End If
    wbRep.Close False

End Sub

Answer 4

抱歉，我已经看到，“报告”是工作簿，而不是工作表。请将 'Report.Cells()' 替换为 'Report.Worksheets("Sheet1").Cells()'