Question

直截了当：

我想在表格上匹配A2＆＃34; PRD＆＃34;对于纸张上的A2＆＃34; CRD＆＃34;，如果这是一个匹配我想要将纸张PRD上的B2与纸张CRD上的B2进行比较，然后将A3相同的东西一直打开到该范围的末尾。如果列AI中的单元格之间没有匹配，则尝试将整行复制到第三张，如果A中的单元格之间存在匹配，但BI中的单元格之间没有匹配，则尝试将行复制到第三行片。

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

我希望我提出正确的问题而且很清楚，谢谢你的帮助!!

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，您应该避免所有这些Select并使用完全限定的对象

请参阅下面的代码，以及代码注释中的解释。

修改后的代码

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

如果，IsError，那么循环比较4列单元格

1 个答案: