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

VBA - compare the cells in two columns with the cells in two other columns

提问by andreas hansson

I have searched far and wide without finding a good answer for this issue.

我已经搜索了很多地方，但没有找到这个问题的好答案。

I have two lists with two columns in each. The lists contains dealer numbers (column A) and part numbers for the dealers (column B). The same value may be duplicate in each of the columns (each dealer has several part numbers and each part number may occur for several dealers).

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

I want the script to start with A1 and B1 in sheet1, check if bothcells have a match in sheet2 - column A and column B and if so mark the equivalent cell in A1 as red, and then move to A2 + B2 to do the same comparison again. In other words, it should check row1 in sheet 1, compare it with each row in Sheet2 for a match, mark the A-cell in Sheet1 red if there is a match, and then move to the next row in Sheet1.

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

Here is where i have problems getting it right; I cannot seem to make the script flexible. My script does not seem to check both Cell A and B in Sheet1 and it does not check the full range in Sheet 2 for each loop.

这是我在正确处理时遇到问题的地方；我似乎无法让脚本变得灵活。我的脚本似乎没有检查 Sheet1 中的 Cell A 和 B，也没有检查 Sheet2 中每个循环的完整范围。

In the next step I would also want the script to check if a third column in Sheet2 is higher than the respective cell in Sheet1, but I should be able to handle that once I get the basics going.

在下一步中，我还希望脚本检查 Sheet2 中的第三列是否高于 Sheet1 中的相应单元格，但是一旦我掌握了基础知识，我应该能够处理它。

Here's how my code looks now:

这是我的代码现在的样子：

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

Thank you!

谢谢！

回答by YowE3K

Close, so close.

很近，很近。

Most of the changes I made to your code were "cosmetic" (e.g. using "B" instead of offsetting one column from "A").

我对您的代码所做的大部分更改都是“装饰性的”（例如，使用“B”而不是从“A”中偏移一列）。

The mainchange is the Ifstatement. After the "cosmetic" changes, your Ifstatement ended up looking like:

的主要变化是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

The problem is that that exits the For jloop as soon as the values in column A match, even if the values in column B didn't match. The Exit Forneeds to only be executed once both column A and column B match, e.g.

问题是，只要For jA 列中的值匹配，即使 B 列中的值不匹配，它也会退出循环。在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

---

---

The final code, after all my changes, ends up as:

经过我所有更改后，最终代码最终为：

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

回答by tretom

to loop until you have data on your sheets:

循环直到您的工作表上有数据：

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

回答by user3598756

you can use AutoFilter():

您可以使用 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