excel - 通过匹配两个工作表中的列值突出显示行中的差异
问题描述
我将数据从数据库检索到 Excel 文件。如果我在数据库中进行更改,并在 excel 文件中检索新的“转储”,我想知道自上次检索数据以来进行了哪些更改。我对编码很陌生,并且遇到了这个问题的局限性。我需要做的是将名称/ID 与 ws1 的第 1 列与 ws2 的第 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 without For。如果我不添加 Next 语句,我会收到一条错误消息,提示 Block If without End If。
对可能出错的地方有什么建议吗?
第二次编辑:
因此,我尝试从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
解决方案
未经测试:
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
推荐阅读
- wordpress - 我更改了我的 Wordpress 主题文件夹。现在我改回来后找不到我的样式表
- angular - Angular 6 在使用模态时从另一个组件调用属性时给出错误“TypeError:无法读取属性”
- r - 返回行中最后一个值 <> NA 的列名
- r - 从R中的截距中排除第一个因素
- django - 如何在另一个模型视图中增加我的文章的价值,例如在 django
- java - 这个 Maven 认证错误表明了什么?
- php - SQL - 从表中选择日期格式并显示在屏幕上
- amazon-web-services - 直接 IP 攻击,ElastickBeanstalk/NGINX
- javascript - Ngrx 选择器未触发更新
- laravel - 在 Laravel 中启动应用程序时查询数据库表一次