我从数据库检索数据到excel文件。如果我在数据库中进行了更改，并在excel文件中检索了一个新的“转储”，我想知道自上次检索数据以来进行了哪些更改。我对编码比较陌生，并且在这个问题上遇到了局限。我需要做的是比较名称/ ID与ws1的colum 1与ws2的colum 1中的匹配名称，并突出显示每行中ws2的差异。但是，随着新名称的添加/删除，该名称可能在每个转储之间位于不同的行中。
我尝试了一些仅比较每个单元格中的值的代码，如果名称/ ID与要比较的工作表在同一行位置，则这非常好。但是，如果名称在不同的行中，则该行下的整个数据集将被视为更改并突出显示。
Private Sub CommandButton1_Click()
Call compareSheets("Sheet1", "Sheet2")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim mycell As Range
Dim mydiffs As Integer
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
'If the cell has a matching value change it to "no fill"
If mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.ColorIndex = 0
End If
Next
'msg to display no. of difference found
MsgBox mydiffs & " differences found", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
WORKSHEET 1
Tag Temperature Pressure
13L0001A1 40 20
13L0002A2 40 25
13L0003A3 35 25
WORKSHEET 2
Tag Temperature Pressure
13L0001A1 40 20
13L0002A2 45 20
13L0003A3 35 25
这是我要比较的数据集的示例。 （非常简化，我的实际数据集包含45个列）。我需要突出显示标签13L0002A2的温度和压力变化。
任何帮助都会得到高度赞赏！
编辑： 这是我要实现的新代码：
Public Sub comparesheets(shtSheet1 As String, shtSheet2 As String)
Dim rowCount1 As Integer
Dim rowCount2 As Integer
rowCount1 = ThisWorkbook.Sheets(1).Range("D2").SpecialCells(xlCellTypeLastCell).Row
rowCount2 = ThisWorkbook.Sheets(2).Range("D2").SpecialCells(xlCellTypeLastCell).Row
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ThisWorkbook.Sheets(1).Range("D2:D" & rowCount1)
Set rng2 = ThisWorkbook.Sheets(2).Range("D2:D" & rowCount2)
Dim var As Variant, iSheet As Integer
'Cycle through all the cells in that column:
For rowCount1 = 4 To rng1
Next rowCount1
'For every cell that is not empty, search through the column "D" in each worksheet for the
'value that matches that cell value in the workbook.
If Not IsEmpty(Cells(rowCount1, 4)) Then
For iSheet = ActiveSheet.Index + 4 To Worksheets.Count
var = Application.Match(Cells(rng1, 4).Value, Worksheets(iSheet).Columns(4), 0)
Next iSheet
End If
'If a matching value is found, then search each row for differences. If difference is found, color the cell yellow.
'otherwise, continue searching until you reach the end of the workbook.
If Not IsError(var) Then
For Each rng1 In ActiveWorkbook.Worksheets(shtSheet1).UsedRange
If Not rng2.Value = rng1.Value Then
rng2.Interior.Color = vbYellow
If Not rng2.Offset(0, 1).Value = rng1.Offset(0, 1).Value Then
rng2.Offset(0, 1).Interior.Color = vbYellow
End If
' Here i get an error with "Next without For"
Next rng1
End If
' If no match is found, color entire row yellow
If IsError(var) Then
EntireRow.Interior.Color = vbYellow
End If
End Sub
如果我在For Each单元格后添加Next语句，则会显示一条错误，提示Next（无For）。如果我不添加Next语句，则会收到一条错误消息，提示“如果没有结束则阻止”。
对可能出什么问题的任何建议？
第二次编辑：
所以我尝试从https://docs.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.match修改示例代码，因为这几乎可以满足我的需要。我一次成功地获得了代码。然后，我清除了所有格式，然后重试，并遇到下标超出范围的错误（“ 9”），我一生都无法找出为什么它只能工作一次，而不是现在。
我使用的代码：
Sub HighlightMatches()
'Declare variables
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long, bln As Boolean, rng1 As Range, rng2 As Range, rowCount1 As Integer, rowCount2 As Integer
rowCount1 = ThisWorkbook.Sheets(1).Range("D4").SpecialCells(xlCellTypeLastCell).Row
rowCount2 = ThisWorkbook.Sheets(2).Range("D4").SpecialCells(xlCellTypeLastCell).Row
Set rng1 = ThisWorkbook.Sheets(1).Range("D4:D" & rowCount1)
Set rng2 = ThisWorkbook.Sheets(2).Range("D4:D" & rowCount2)
'Set up the count as the number of filled rows in the first column of Sheet1.
iRowL = Cells(Rows.Count, 4).End(xlUp).Row
'Cycle through all the cells in that column:
For iRow = 4 To iRowL
'For every cell that is not empty, search through the column "D" in each worksheet in the
'workbook for a value that matches that cell value.
If Not IsEmpty(Cells(iRow, 4)) Then
For iSheet = ActiveSheet.Index + 1 To Worksheets.Count
bln = False
var = Application.Match(Cells(iRow, 4).Value, Worksheets(iSheet).Columns(4), 0)
'If you find a matching value, indicate success by setting bln to true and exit the loop;
'otherwise, continue searching until you reach the end of the workbook.
If Not IsError(var) Then
bln = True
Exit For
End If
Next iSheet
End If
'If match is found, compare row for each colum;
'if no match is found, color cell yellow.
If Not bln = True Then
For Each rng1 In ThisWorkbook.Worksheets(1).UsedRange
If Not rng1.Value = ThisWorkbook.Worksheets(2).Cells(rng2.Row, 4) Then
rng1.Interior.ColorIndex = vbYellow
End If
Next rng1
End If
Next iRow
End Sub
答案 0 :(得分：0)
未经测试：
Public Sub comparesheets(shtSheet1 As String, shtSheet2 As String)
Dim ws1 As Worksheet, ws2 As Worksheet, c As Range, cTest As Range, cMatch As Range, m
Set ws1 = ThisWorkbook.Sheets(1)
Set ws2 = ThisWorkbook.Sheets(2)
For Each c In ws1.Range(ws1.Range("D2"), ws1.Cells(ws1.Rows.Count, "D").End(xlUp)).Cells
m = Application.Match(c.Value, ws2.Columns(4), 0)
If Not IsError(m) Then
'matched rows - compare values
For Each cTest In Application.Intersect(c.EntireRow, ws1.UsedRange).Cells
Set cMatch = ws2.Cells(m, cTest.Column) '<<< EDIT
If cTest.Value <> cMatch.Value Then
cMatch.Interior.Color = vbYellow
End If
Next cTest
Else
'no matched row
c.EntireRow.Interior.Color = vbYellow
Debug.Print "No match for '" & c.Value & "' (Row " & c.Row & ")"
End If
Next c
End Sub
答案 1 :(得分：0)
感谢TIm，这是我的问题的解决方案：
Private Sub CommandButton1_Click()
Call comparesheets("Sheet1", "Sheet2")
End Sub
Public Sub comparesheets(shtSheet1 As String, shtSheet2 As String)
Dim ws1 As Worksheet, ws2 As Worksheet, c As Range, cTest As Range, cMatch As Range, m
Set ws1 = ThisWorkbook.Sheets(1)
Set ws2 = ThisWorkbook.Sheets(2)
For Each c In ws1.Range(ws1.Range("D2"), ws1.Cells(ws1.Rows.Count, "D").End(xlUp)).Cells
m = Application.Match(c.Value, ws2.Columns(4), 0)
If Not IsError(m) Then
'match row, compare values
For Each cTest In Application.Intersect(c.EntireRow, ws1.UsedRange).Cells
Set cMatch = ws2.Cells(m, cTest.Column)
If cTest.Value <> cMatch.Value Then
cMatch.Interior.Color = vbGreen
End If
Next cTest
Else
'no match found
c.EntireRow.Interior.Color = vbRed
Debug.Print "No match for '" & c.Value & "' (Row " & c.Row & ")"
End If
Next c
'do a loop for worksheet 2
For Each c In ws2.Range(ws2.Range("D2"), ws2.Cells(ws2.Rows.Count, "D").End(xlUp)).Cells
m = Application.Match(c.Value, ws1.Columns(4), 0)
If Not IsError(m) Then
'match row, compare values
For Each cTest In Application.Intersect(c.EntireRow, ws2.UsedRange).Cells
Set cMatch = ws1.Cells(m, cTest.Column)
If cTest.Value <> cMatch.Value Then
cMatch.Interior.Color = vbGreen
End If
Next cTest
Else
'no match
c.EntireRow.Interior.Color = vbRed
Debug.Print "No match for '" & c.Value & "' (Row " & c.Row & ")"
End If
Next c
End Sub
Private Sub CommandButton2_Click()
'reset format button
ThisWorkbook.Sheets(1).Cells.ClearFormats
ThisWorkbook.Sheets(2).Cells.ClearFormats
End Sub