Question

我没有为这个问题找到一个好的答案，而是广泛搜索。

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

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

这是我遇到问题的地方;我似乎无法使脚本灵活。我的脚本似乎没有检查Sheet1中的单元格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

关闭，如此接近。

我对您的代码所做的大部分更改都是“装饰性的”（例如，使用“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列中的值匹配，就会退出For j循环，即使B列中的值不匹配也是如此。只有在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

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

3 个答案: