我有一個作業簿，包括 2 張紙。在每個作業表中，它都有幾列，例如名稱（A 列）、狀態（B 列）和 ID（C 列）。但是兩張紙的行排序順序都是隨機的。根據ID，我需要使用VBA來比較Name和State的值。如果它們不匹配，則突出顯示 2 張紙中的 2 個單元格。結果應該是這樣的：
但是如果 ID 具有相同的順序序列，我下面的代碼只能針對 A 列運行。
我知道如果我使用條件格式來創建新規則或使用 vlookup 或索引和匹配函式進行比較會容易得多。但我被要求使用 VBA
謝謝！
Sub Test_Sheet()
Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim lastRow As Long
Dim lastRow2 As Long
Dim thisRow As Long
Dim thisRow2 As Long
Dim lastCol As Long
Dim lastCol2 As Long
Dim thisCol As Long
Dim thisCol2 As Long
Dim foundRow As Range
Dim foundRow2 As Range
Dim lastFoundRow As Long
Dim lastFoundRow2 As Long
Dim searchRange As Range
Dim searchRange2 As Range
Dim isMatch As Boolean
Dim isMatch2 As Boolean
' Set up the sheets
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
' Find the last row of the active sheet
lastRow = sheetOne.Cells(sheetOne.Rows.Count, "A").End(xlUp).Row
lastRow2 = sheetOne.Cells(sheetOne.Rows.Count, "B").End(xlUp).Row
' Set the search range on the other sheet
Set searchRange = sheetTwo.Range("A2:A" & sheetTwo.Cells(sheetTwo.Rows.Count, "A").End(xlUp).Row)
Set searchRange2 = sheetTwo.Range("B2:B" & sheetTwo.Cells(sheetTwo.Rows.Count, "B").End(xlUp).Row)
' Look at all rows
For thisRow = 1 To lastRow
' Find the last column on this row
lastCol = sheetOne.Cells(thisRow, sheetOne.Columns.Count).End(xlToLeft).Column
' Find the first match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, searchRange(searchRange.Count), xlValues, xlWhole)
' Must find something to continue
Do While Not foundRow Is Nothing
' Remember the row we found it on
lastFoundRow = foundRow.Row
' Check the found row has the same number of columns
If sheetTwo.Cells(lastFoundRow, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol Then
' Assume it's a match
isMatch = True
' Look at all the column values
For thisCol = 1 To lastCol
' Compare the column values
If sheetTwo.Cells(lastFoundRow, thisCol).Value <> sheetOne.Cells(thisRow, thisCol).Value Then
' No match
isMatch = False
Exit For
End If
Next thisCol
' If it's still a match then highlight the row
If isMatch Then sheetOne.Range(sheetOne.Cells(thisRow, "A"), sheetOne.Cells(thisRow, lastCol)).Interior.ColorIndex = 3
End If
' Find the next match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, foundRow, xlValues, xlWhole)
' Quit out when we wrap around
If foundRow.Row <= lastFoundRow Then Exit Do
Loop
Next thisRow
For thisRow2 = 1 To lastRow2
lastCol2 = sheetOne.Cells(thisRow2, sheetOne.Columns.Count).End(xlToLeft).Column
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, searchRange2(searchRange2.Count), xlValues, xlWhole)
Do While Not foundRow2 Is Nothing
lastFoundRow2 = foundRow2.Row
If sheetTwo.Cells(lastFoundRow2, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol2 Then
isMatch2 = True
For thisCol2 = 1 To lastCol2
If sheetTwo.Cells(lastFoundRow2, thisCol2).Value <> sheetOne.Cells(thisRow2, thisCol2).Value Then
isMatch2 = False
Exit For
End If
Next thisCol2
If isMatch2 Then sheetOne.Range(sheetOne.Cells(thisRow2, "B"), sheetOne.Cells(thisRow2, lastCol2)).Interior.ColorIndex = 5
End If
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, foundRow2, xlValues, xlWhole)
If foundRow2.Row <= lastFoundRow2 Then Exit Do
Loop
Next thisRow2
End Sub
uj5u.com熱心網友回復：
請嘗試下一個代碼。它使用陣列來加快迭代速度，處理記憶體和Union范圍中的匹配，最后一次為內部單元格著色。修改每個單元格的內部會消耗 Excel 資源并且需要時間：
Sub testCompareIDs()
Dim sheetOne As Worksheet, sheetTwo As Worksheet, lastRow1 As Long, lastRow2 As Long, i As Long, j As Long
Dim rng1 As Range, rng2 As Range, arr1, arr2, rngColA1 As Range, rngColA2 As Range, rngColB1 As Range, rngColB2 As Range
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
lastRow1 = sheetOne.cells(sheetOne.rows.count, "C").End(xlUp).row
lastRow2 = sheetTwo.cells(sheetOne.rows.count, "C").End(xlUp).row
Set rng1 = sheetOne.Range("A2:C" & lastRow1)
Set rng2 = sheetTwo.Range("A2:C" & lastRow2)
arr1 = rng1.value: arr2 = rng2.value 'place ranges to be processed in arrays, for faster iteration
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i, 3) = arr2(j, 3) Then
If arr1(i, 1) <> arr2(j, 1) Then
If rngColA1 Is Nothing Then
Set rngColA1 = rng1.cells(i, 1)
Set rngColA2 = rng2.cells(j, 1)
Else
Set rngColA1 = Union(rngColA1, rng1.cells(i, 1))
Set rngColA2 = Union(rngColA2, rng2.cells(j, 1))
End If
End If
If arr1(i, 2) <> arr2(j, 2) Then
If rngColB1 Is Nothing Then
Set rngColB1 = rng1.cells(i, 2)
Set rngColB2 = rng2.cells(j, 2)
Else
Set rngColB1 = Union(rngColB1, rng1.cells(i, 2))
Set rngColB2 = Union(rngColB2, rng2.cells(j, 2))
End If
End If
Exit For 'exit iteration since the ID has been found
End If
Next j
Next i
If Not rngColA1 Is Nothing Then
rngColA1.Interior.ColorIndex = 3
rngColA2.Interior.ColorIndex = 3
End If
If Not rngColB1 Is Nothing Then
rngColB1.Interior.ColorIndex = 3
rngColB2.Interior.ColorIndex = 3
End If
End Sub
字串比較區分大小寫。該代碼可以調整為不區分大小寫（Ucase用于每個比較行）
請在測驗后發送一些反饋。
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/433521.html