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

Question

我有两本很大的练习册(旧的&新)的年度员工数据，并试图比较。每个工作簿都有相同的标题，雇员的顺序是随机的。以下是我想要完成的:

1. 使用员工ID(列D)作为参考，比较他们是否更改了信息，特别是医师(列L)。
2. 生成报告，突出显示不同的单元格，并添加列(更改信息"Yes/No")，如果有更改或没有。

问题:这段代码只比较单元格(花了很多时间)，而不是每个员工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人，如果多于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

使用Dictionary作为查找表，查找旧数据表中每个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()">