VBA-比较两列中的单元格与其他两列中的单元格

Question

我已经四处搜寻，但找不到这个问题的好答案。

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

我希望脚本以Sheet1中的A1和B1开头，检查Sheet2中的两个单元格是否都匹配-A列和B列，如果是，则将A1中的等效单元格标记为红色，然后移至A2 + B2进行同样的比较。 换句话说，它应该检查工作表1中的row1，并将其与Sheet2中的每一行进行比较，如果匹配则将Sheet1中的A单元标记为红色，然后移至Sheet1中的下一行。

这是我遇到问题的地方； 我似乎无法使脚本灵活。 我的脚本似乎没有在Sheet1中同时检查单元格A和B，并且没有为每个循环检查Sheet 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

亲，亲

我对您的代码所做的大多数更改都是“化妆品”的（例如，使用“ 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

问题在于，即使B列中的值不匹配，只要A列中的值匹配，也会退出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