VBA – 将两列中的单元格与另外两列中的单元格进行比较

我没有find一个好的答案，这个问题已经遍地search。

我有两个列表，每列两列。 清单包含经销商编号（A栏）和经销商的零件编号（B栏）。 相同的值可能在每一列中都是重复的（每个经销商有几个零件号，每个零件号可能出现在几个经销商处）。

我希望脚本以sheet1中的A1和B1开始，检查两个单元格是否在sheet2 – 列A和列B中匹配，如果是，则将A1中的等效单元格标记为红色，然后移至A2 + B2以执行相同的比较再次。 换句话说，它应该检查第1页中的第1行，将其与Sheet2中的每一行进行比较，如果存在匹配，则将Sheet1中的A单元格标记为红色，然后移至Sheet1中的下一行。

这里是我遇到问题的地方; 我似乎无法使脚本灵活。 我的脚本似乎没有检查Sheet 1中的单元格A和B，它不检查每个循环的表2中的全部范围。

在下一步中，我还希望脚本检查Sheet2中的第三列是否高于Sheet1中的相应单元格，但是一旦我获得了基本知识，我就能够处理这个问题。

以下是我的代码现在的样子：

Sub Comparestwocolumns() Dim i As Long Dim lastrow As Long Dim ws As Worksheet Set ws = Sheet1 Set ws2 = Sheet2 For i = 1 To 500000 If IsEmpty(ws.Range("A" & i)) = True Then Exit For End If For j = 1 To 500000 If IsEmpty(ws2.Range("A" & j)) = True Then Exit For End If If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then If ws.Range("A" & i).Offset(0, 1).Value = ws2.Range("A" & j).Offset(0, 1).Value Then ws.Range("A" & i).Interior.Color = vbRed Else ws.Range("A" & i).Interior.Color = vbWhite End If Exit For End If Next j Next i MsgBox ("Finished ") End Sub 

谢谢！

Answer 1

closures，如此接近。

我对你的代码所做的大部分修改都是“整体”（例如，使用“B”而不是从“A”中偏移一列）。

主要的变化是If语句。 在“化妆品”变化后，你的If语句结果如下：

 If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then ws.Range("A" & i).Interior.Color = vbRed End If Exit For End If 

问题是，只要列A中的值匹配，即使列B中的值不匹配，也会退出For j循环。 只有A列和B列匹配时， Exit For才需要执行，例如

 If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then ws.Range("A" & i).Interior.Color = vbRed Exit For End If End If 

---

最后的代码，毕竟我的变化，结束为：

 Sub Comparestwocolumns() Dim i As Long Dim j As Long Dim lastrow As Long Dim ws As Worksheet Set ws = Sheet1 Set ws2 = Sheet2 For i = 1 To 500000 If IsEmpty(ws.Range("A" & i)) Then Exit For End If For j = 1 To 500000 If IsEmpty(ws2.Range("A" & j)) Then Exit For End If If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then ws.Range("A" & i).Interior.Color = vbRed Exit For End If End If Next j Next i MsgBox ("Finished ") End Sub 

Answer 2

循环，直到您的床单上有数据：

 Option Explicit Sub matcher() Dim i As Integer, j As Integer i = 1 While Sheets(1).Cells(i, 1).Value <> "" j = 1 While Sheets(2).Cells(j, 1).Value <> "" If Sheets(1).Cells(i, 1).Value = Sheets(2).Cells(j, 1).Value And Sheets(1).Cells(i, 2).Value = Sheets(2).Cells(j, 2).Value Then Sheets(1).Cells(i, 1).Interior.ColorIndex = 3 End If j = j + 1 Wend i = i + 1 Wend End Sub 

Answer 3

你可以使用AutoFilter（）：

 Option Explicit Sub Comparestwocolumns() Dim firstShtRng As Range, filteredRng As Range, colorRng As Range, cell As Range With Worksheets("Sheet2") '<--| reference your 2nd sheet Set firstShtRng = .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| gather its column A values from row 1 down to last not empty row to be checked in 2nd sheet End With With Sheets("Sheet1") '<--| reference your 1st sheet With .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column A range from row 1 down to last not empty row .AutoFilter Field:=1, Criteria1:=Application.Transpose(firstShtRng.Value), Operator:=xlFilterValues '<--| filter referenced cells with 'firstShtRng' values Set filteredRng = .SpecialCells(xlCellTypeVisible) '<--| set filtered cells to 'filteredRng' range Set colorRng = .Offset(, 1).Resize(1, 1) '<--| initialize 'colorRng' to a "dummy" cell that's out of range of interest: it'll be used to avoid subsequent checking against "nothing" before calling 'Union()' method and eventually discharged End With .AutoFilterMode = False End With For Each cell In filteredRng '<--| loop through filtered cells in "Sheet1" If firstShtRng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Offset(, 1) = cell.Offset(, 1) Then Set colorRng = Union(colorRng, cell) '<--| if current cell adjacent value matches corresponding value in "Sheet2" then update 'colorRng' Next Set colorRng = Intersect(filteredRng, colorRng) '<--| get rid of "dummy" cell If Not colorRng Is Nothing Then colorRng.Interior.Color = vbRed '<--| if any survived cell in "Sheet1" then delete corresponding rows End Sub