VBA-将两列中的细胞与其他两个列中的单元进行比较

Question

我已经搜索了很广泛，没有找到这个问题的好答案。

我有两个列表，每个列表中有两个列。列表包含经销商号码（A列）和经销商的零件号（B列）。每个列中都可以重复相同的值（每个经销商都有几个零件号，并且每个零件号可能会发生在几个经销商处）。

我希望该脚本以Sheet1中的A1和B1开头，检查两个两个单元格在Sheep2 -A和B列B中是否具有匹配然后移动到A2 B2进行同样的比较。换句话说，它应该在表1中检查Row1，将其与Sheep2中的每一行进行比较以进行匹配，如果有匹配，请在Sheet1中标记A-Cell，然后在Sheep1中移动到Sheep1中的下一行。

这是我遇到问题的地方；我似乎无法使脚本灵活。我的脚本似乎在Sheep1中没有检查单元格A和B，并且不会检查每个循环中的第2页中的完整范围。

在下一步中，我还希望脚本检查Sheep2中的第三列是否高于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"中取代一列）。

main 更改是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列中的值即使在A列中的值中退出For j循环。Exit For仅一旦A列和B列匹配，例如。

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