我正在尝试比较两个工作表并突出显示更改。这两个工作表是定期更新的同一数据集的不同版本，我需要跟踪所做的更改。对于修改的值和新添加的值，应分别突出显示更改（单元格颜色和用户预定义的字体颜色）。
我的代码适用于 100 行的小样本，但原始文件有约 7000 行，并且需要很长时间才能运行整个数据集的代码。
我添加了一个进度条以获得更好的用户界面，因为代码需要一些时间才能运行。
Sub Highlight()
Dim DataRange As Range
Dim SelCell As Range
Dim CurVer As String
Dim CompVer As String
Dim IntColMod As Long
Dim IntColAdd As Long
Dim FontColMod As Long
Dim FontColAdd As Long
Dim ModCellCount As Long
Dim AddCellCount As Long
'Pre-defined highlight format
IntColMod = Worksheets("Version recon").Range("Modified_Value_Format").Interior.Color
FontColMod = Worksheets("Version recon").Range("Modified_Value_Format").Font.Color
IntColAdd = Worksheets("Version recon").Range("Added_Value_Format").Interior.Color
FontColAdd = Worksheets("Version recon").Range("Added_Value_Format").Font.Color
ModCellCount = 0
AddCellCount = 0
CurVer = Worksheets("Version recon").Range("Current_Version").Value
CompVer = Worksheets("Version recon").Range("Compare_Version").Value
'Debug.Print CurVer
'Debug.Print CompVer
Worksheets(CurVer).Activate
Worksheets(CurVer).Unprotect
Set DataRange = ActiveCell.CurrentRegion
'Debug.Print DataRange.Address
Dim CellCount As Long
CellCount = DataRange.Cells.Count
'Debug.Print CellCount
Code_Progress_Bar.Show
Dim i As Long
i = 1
For Each SelCell In DataRange
If SelCell.Text <> Worksheets(CompVer).Range(SelCell.Address).Text And IsEmpty(Worksheets(CompVer).Range(SelCell.Address).Value) Then
Worksheets(CurVer).Range(SelCell.Address).Interior.Color = IntColAdd
Worksheets(CurVer).Range(SelCell.Address).Font.Color = FontColAdd
AddCellCount = AddCellCount + 1
Debug.Print SelCell.Address
ElseIf SelCell.Text <> Worksheets(CompVer).Range(SelCell.Address).Text Then
Worksheets(CurVer).Range(SelCell.Address).Interior.Color = IntColMod
Worksheets(CurVer).Range(SelCell.Address).Font.Color = FontColMod
ModCellCount = ModCellCount + 1
Debug.Print SelCell.Address
End If
DoEvents
Code_Progress_Bar.Label2.Width = Code_Progress_Bar.Label1.Width * i / CellCount
Code_Progress_Bar.Label3.Caption = Format(i / CellCount * 100, "#.0") & "% completed."
i = i + 1
Next SelCell
Unload Code_Progress_Bar
Beep
MsgBox "All changes are highlighted in Tab: " & CurVer, , "Code run completed"
Worksheets(CurVer).Protect
ActiveWorkbook.Sheets("Version Recon").Range("ModifiedCellCount").Value = ModCellCount
ActiveWorkbook.Sheets("Version Recon").Range("NewlyAddedCellCount").Value = AddCellCount
'ActiveWorkbook.Sheets("Version Recon").Range("Current_Version").Value = SheetRename
End Sub
Option Explicit
Sub Highlight()
Dim CurVer As String, CompVer As String
Dim IntColMod As Long, IntColAdd As Long
Dim FontColMod As Long, FontColAdd As Long
Dim ModCellCount As Long, AddCellCount As Long
Dim t0 As Single: t0 = Timer
ModCellCount = 0
AddCellCount = 0
'Pre-defined highlight format
With Worksheets("Version recon")
IntColMod = .Range("Modified_Value_Format").Interior.Color
FontColMod = .Range("Modified_Value_Format").Font.Color
IntColAdd = .Range("Added_Value_Format").Interior.Color
FontColAdd = .Range("Added_Value_Format").Font.Color
CurVer = .Range("Current_Version").Value
CompVer = .Range("Compare_Version").Value
End With
' arrays to compare values
Dim arCur, arComp, sAddr As String, i As Long, j As Long
Dim cel As Range, rng0 As Range, rngAdd As Range, rngMod As Range
With Worksheets(CurVer)
.Activate
.Unprotect
sAddr = .UsedRange.Address
Set rng0 = .UsedRange.Cells(1, 1) ' top left
arCur = .Range(sAddr).Value
'Debug.Print sAddr
End With
arComp = Worksheets(CompVer).Range(sAddr).Value
For i = 1 To UBound(arCur)
For j = 1 To UBound(arCur, 2)
' compare
If IsError(arComp(i, j)) Then arComp(i, j) = "#N/A"
If IsError(arCur(i, j)) Then arCur(i, j) = "#N/A"
If arComp(i, j) <> arCur(i, j) Then
Set cel = rng0.Offset(i - 1, j - 1)
' add or mod
If Len(arComp(i, j)) = 0 Then
If rngAdd Is Nothing Then
Set rngAdd = cel
Else
Set rngAdd = Union(rngAdd, cel)
End If
AddCellCount = AddCellCount + 1
Else
If rngMod Is Nothing Then
Set rngMod = cel
Else
Set rngMod = Union(rngMod, cel)
End If
ModCellCount = ModCellCount + 1
End If
End If
Next
Next
' color adds
If Not rngAdd Is Nothing Then
rngAdd.Interior.Color = IntColAdd
rngAdd.Font.Color = FontColAdd
Debug.Print "Add", AddCellCount, rngAdd.Address
End If
' color mods
If Not rngMod Is Nothing Then
rngMod.Interior.Color = IntColMod
rngMod.Font.Color = FontColMod
Debug.Print "Mod", ModCellCount, rngMod.Address
End If
MsgBox "All changes are highlighted in Tab: " & CurVer, vbInformation, _
"Code run in " & Format(Timer - t0, "0.0 secs")
Worksheets(CurVer).Protect
With ActiveWorkbook.Sheets("Version Recon")
.Range("ModifiedCellCount").Value = ModCellCount
.Range("NewlyAddedCellCount").Value = AddCellCount
'.Range("Current_Version").Value = SheetRename ??
End With
End Sub
将数据加载到数组中并进行比较是一种更有效的方法。您甚至可能不再需要进度条。
注意： 由于缺乏示例数据，代码未经测试。
Option Explicit
Sub Highlight()
Dim CurVer As String
Dim CompVer As String
Dim IntColMod As Long
Dim IntColAdd As Long
Dim FontColMod As Long
Dim FontColAdd As Long
Dim verSht As Worksheet, currSht As Worksheet, CompSht As Worksheet
Set verSht = Worksheets("Version recon")
IntColMod = verSht.Range("Modified_Value_Format").Interior.Color
FontColMod = verSht.Range("Modified_Value_Format").Font.Color
IntColAdd = verSht.Range("Added_Value_Format").Interior.Color
FontColAdd = verSht.Range("Added_Value_Format").Font.Color
CurVer = verSht.Range("Current_Version").Value
CompVer = verSht.Range("Compare_Version").Value
Set currSht = Worksheets(CurVer)
Set CompSht = Worksheets(CompVer)
currSht.Unprotect
Dim arrCurr, arrComp, ltRow As Long, ltCol As Long
With currSht.UsedRange
' get row# and col# of the top-left cell (table may not start from A1)
ltRow = .Cells(1).Row
ltCol = .Cells(1).Column
' load data into array
arrCurr = .Value
arrComp = CompSht.Range(.Address).Value
End With
Dim r As Long, c As Long, addRng As Range, modRng As Range
' loop through cells
For r = 1 To UBound(arrCurr)
For c = 1 To UBound(arrCurr, 2)
' *** Update ***
If CStr(arrCurr(r, c)) <> CStr(arrComp(r, c)) Then ' found different
If Len(CStr(arrComp(r, c))) = 0 Then ' new added content
MergeRng addRng, currSht.Cells(r + ltRow - 1, c + lrCol - 1)
Else ' modify
MergeRng modRng, currSht.Cells(r + ltRow - 1, c + lrCol - 1)
End If
End If
Next
Next
' apply formatting
If Not addRng Is Nothing Then
With addRng
.Interior.Color = IntColAdd
.Font.Color = FontColAdd
verSht.Range("NewlyAddedCellCount").Value = .Cells.Count
End With
End If
If Not modRng Is Nothing Then
With modRng
.Interior.Color = IntColMod
.Font.Color = FontColMod
verSht.Range("ModifiedCellCount").Value = .Cells.Count
End With
End If
MsgBox "All changes are highlighted in Tab: " & CurVer, , "Code run completed"
Worksheets(CurVer).Protect
End Sub
' helper UDF to merge two Range objects
Function MergeRng(ByRef RngAll As Range, ByRef RngSub As Range) As Range
If RngAll Is Nothing Then
Set RngAll = RngSub
ElseIf Not RngSub Is Nothing Then
Set RngAll = Application.Union(RngAll, RngSub)
End If
Set MergeRng = RngAll
End Function
添加条件格式规则通常比单独格式化多个单元格要快。 但您可能需要考虑在审核后删除条件格式。
Option Explicit
Function GetCurrentWorksheet() As Worksheet
Dim Name As String
Name = Worksheets("Version recon").Range("Current_Version").Value
Set GetCurrentWorksheet = Worksheets(Name)
End Function
Function GetCompareWorksheet() As Worksheet
Dim Name As String
Name = Worksheets("Version recon").Range("Compare_Version").Value
Set GetCompareWorksheet = Worksheets(Name)
End Function
Sub AddConditionalFormattingRules()
Dim t As Double: t = Timer
Dim wsCurrentWorksheet As Worksheet
Dim wsCompareWorksheet As Worksheet
Dim Target As Range
Dim CurrentSheetName As String
Dim CompareSheetName As String
Dim StartCellAddress As String
' Define worksheets
Set wsCurrentWorksheet = GetCurrentWorksheet
Set wsCompareWorksheet = GetCompareWorksheet
CurrentSheetName = wsCurrentWorksheet.Name
CompareSheetName = wsCompareWorksheet.Name
' Define the range in the "Compare" sheet for conditional formatting
With wsCompareWorksheet
Set Target = Union(.UsedRange, .Range(wsCurrentWorksheet.UsedRange.Address))
End With
' Get the address of the first cell in the target range
StartCellAddress = Target.Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
' Clear existing conditional formatting
Target.FormatConditions.Delete
' Rule 1: If the cell in the current sheet is empty and the corresponding cell in the compare sheet is not empty, apply "Neutral"
With Target.FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(ISBLANK('" & CurrentSheetName & "'!" & StartCellAddress & "),NOT(ISBLANK('" & CompareSheetName & "'!" & StartCellAddress & ")))")
.Interior.Color = Worksheets("Version recon").Range("Added_Value_Format").Interior.Color
.Font.Color = Worksheets("Version recon").Range("Added_Value_Format").Font.Color
End With
' Rule 2: If the cell in the current sheet is not empty and differs from the corresponding cell in the compare sheet, apply "Bad"
With Target.FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK('" & CurrentSheetName & "'!" & StartCellAddress & ")),'" & CurrentSheetName & "'!" & StartCellAddress & " <> '" & CompareSheetName & "'!" & StartCellAddress & ")")
.Interior.Color = Worksheets("Version recon").Range("Modified_Value_Format").Interior.Color
.Font.Color = Worksheets("Version recon").Range("Modified_Value_Format").Font.Color
End With
Debug.Print Timer - t
' MsgBox "Conditional formatting rules applied.", vbInformation
End Sub