If, IsError, Then 循环比较 4 列单元格

Question

开门见山：

我正在尝试将 sheet "PRD" 上的 A2 与 sheet "CRD" 上的 A2 进行匹配，如果这是匹配，我想比较 [=22] 上的 B2 =] PRD 到 sheet CRD 上的 B2，然后是 A3 同样的事情，一直到范围的尽头。如果 A 列中的单元格之间不匹配，我将尝试将整行复制到第三行 sheet，如果 A 中的单元格之间存在匹配但 B 中的单元格之间不匹配，我将尝试复制排到第三 sheet。

我被卡住了，我想在查看代码和谷歌搜索几个小时后，无法检查 B 列...我似乎能够检查、复制和粘贴与列中的内容不匹配的单元格罚款。

我希望我问的是正确的问题并且很清楚，感谢您的帮助！！

Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Dim cell As Range
Dim cell2 As Range
Dim lastrow As Long

'CRD date
With ThisWorkbook.Worksheets("CRD")
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set r1 = .Range("A2:A" & lastrow)
End With

'CRD quantity
With ThisWorkbook.Worksheets("CRD")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set r3 = .Range("B2:B" & lastrow)
End With

'PRD date
With ThisWorkbook.Worksheets("PRD")
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set r2 = .Range("A2:A" & lastrow)
End With

'PRD quantity
With ThisWorkbook.Worksheets("PRD")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set r4 = .Range("B2:B" & lastrow)
End With

'match PRD date to CRD date: output "Found" for record, or copy/paste onto report page
Range("A2").Select
For Each cell In r1
    If IsError(Application.Match(cell, r2, 0)) Then
    'select active cell's row and copy, pasting in report page
        Rows(ActiveCell.Row).Select
        Selection.Copy
        Sheets("Sheet1").Select
        Range("A1").Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("CRD").Select
        Application.CutCopyMode = False

    'if no error check quantity(B) of same cell, if match continue, if no match copy
    ElseIf IsError(Application.Match(r3, r4, 0)) Then
        For Each cell2 In r3
            Rows(ActiveCell.Row).Select
            Selection.Copy
            Sheets("Sheet1").Select
            Range("A1").Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Sheets("CRD").Select
            ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
            Application.CutCopyMode = False
        Next
    Else
    End If
    ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Next

End Sub

Answer 1

您的代码过于依赖 Select、ActiveCell、Selection 和 Activate，您应该避免所有这些 Selecting 并使用完全限定对象代替。

查看下面的代码，以及代码注释中的解释。

修改代码

Option Explicit

Sub Match2Columns()

Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Dim cell As Range
Dim cell2 As Range
Dim lastrow As Long

'CRD date
With ThisWorkbook.Worksheets("CRD")
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set r1 = .Range("A2:A" & lastrow)
End With

'CRD quantity
With ThisWorkbook.Worksheets("CRD")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set r3 = .Range("B2:B" & lastrow)
End With

'PRD date
With ThisWorkbook.Worksheets("PRD")
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set r2 = .Range("A2:A" & lastrow)
End With

'PRD quantity
With ThisWorkbook.Worksheets("PRD")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set r4 = .Range("B2:B" & lastrow)
End With

Dim PasteRow As Long ' row to paste at "sheet1"

'match PRD date to CRD date: output "Found" for record, or copy/paste onto report page
With ThisWorkbook.Worksheets("CRD") ' <-- make sure you are looping and copying from "CRD" sheet
    For Each cell In r1
        If IsError(Application.Match(cell, r2, 0)) Then
            ' select active cell's row and copy, pasting in report page
            .Rows(cell.Row).Copy

            ' get last empty row and add 1 row where to paste
            PasteRow = Sheets("Sheet1").Range("A1").End(xlDown).Row + 1

            ' paste action
            Sheets("Sheet1").Range("A" & PasteRow).PasteSpecial Paste:=xlPasteValues

            Application.CutCopyMode = False

        'if no error check quantity(B) of same cell, if match continue, if no match copy
        ElseIf IsError(Application.Match(r3, r4, 0)) Then
            For Each cell2 In r3
                ' select active cell's row and copy, pasting in report page
                .Rows(cell2.Row).Copy

                ' get last empty row and add 1 row where to paste
                PasteRow = Sheets("Sheet1").Range("A1").End(xlDown).Row + 1

                ' paste action
                Sheets("Sheet1").Range("A" & PasteRow).PasteSpecial Paste:=xlPasteValues

                Application.CutCopyMode = False
            Next cell2
        Else
            ' you are doing nothing here, not sure why you need it ???
        End If
    Next cell
End With

End Sub

If, IsError, Then 循环比较 4 列单元格

If, IsError, Then Loop Comparing 4 Columns of Cells

excel

vba

string-matching