我有兩個巨大的年度員工資料作業簿（舊的和新的）并試圖進行比較。每個作業簿都有相同的標題，員工的順序是隨機的。這是我想要完成的：
- 使用員工 ID（在 D 列中）作為參考并比較他們是否更改了資訊，特別是 Physician（在 L 列中）。
- 如果有更改，則生成報告突出顯示具有添加列的不同單元格（更改資訊“是/否”）。
問題：此代碼僅逐個單元地比較（花了很多時間）而不是每個員工 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
uj5u.com熱心網友回復：
我會在這里做以下事情：
首先，我會為 EmployeeID 和我在兩個作業表中找到它們的行創建一個陣列。
為此，我需要宣告一個 RecordType（必須在模塊的開頭定義，而不是在程式中！）我假設您需要處理的員工少于 1024 名，如果更多，只需在 Dim 中使用更高的值-陳述。我還假設 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下測驗片段，所以可能會出現一些小錯誤。請嘗試修復它。
uj5u.com熱心網友回復：
這是您的邏輯代碼：
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
uj5u.com熱心網友回復：
使用字典作為舊資料表上每個 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
uj5u.com熱心網友回復：
對不起，我已經監督過，“報告”是一本作業簿，而不是一張紙。請用'Report.Worksheets("Sheet1").Cells()'替換'Report.Cells()'
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/323734.html