在列中搜索 1 并在找到时将整行粘贴到另一个工作表？

Question

我正在为一些卡在循环中的代码而苦苦挣扎。我试图让代码复制 BD 列中值为 1 的任何行，并将整行的值粘贴到另一个工作表中的下一个空行中。我使用的代码如下

Sub FindIssues()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
Sheets("Macro Worksheet").Select
If Range("BD" & i).Value = "1" Then Rows(i).Select
Selection.Copy
Sheets("Macro Worksheet 2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

  Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
 Loop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Sheets("Macro Worksheet").Select


Next i
End Sub

感谢您的帮助

Answer 1

宏工作表

Option Explicit

Sub CopyEntireRow()
Application.ScreenUpdating = False
    Dim src As Worksheet
    Set src = Sheets("Macro Worksheet")

    Dim trgt As Worksheet
    Set trgt = Sheets("Macro Worksheet 2")

    Dim i As Long
    For i = 1 To src.Range("A" & Rows.Count).End(xlUp).Row
        If src.Range("A" & i) = 1 Then
            ' calling the copy paste procedure
            CopyPaste src, i, trgt
        End If
    Next i
Application.ScreenUpdating = True
End Sub

' this sub copoes and pastes the entire row into a different sheet
' below the last used row
Private Sub CopyPaste(ByRef src As Worksheet, ByVal i As Long, ByRef trgt As Worksheet)
    src.Activate
    src.Rows(i & ":" & i).Copy
    trgt.Activate
    Dim nxtRow As Long
    nxtRow = trgt.Range("A" & Rows.Count).End(xlUp).Row + 1
    trgt.Rows(nxtRow & ":" & nxtRow).PasteSpecial _
        Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

宏工作表 2

Answer 2

我已经复制了您的 2 张工作表，其中包含

的宏工作表上的 A 列

第 3 行和第 5 行包含 1 的 BD 列

所以我希望第 3 行和第 5 行复制到宏工作表 2 的第 1 行和第 2 行。

当我在宏工作表上选择空白单元格 A1 运行 FindIssues 时，我得到了意外的结果

如果您查看并单步执行您的代码（重新格式化和注释）：

Option Explicit

Sub FindIssues()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
    Sheets("Macro Worksheet").Select

    'Select the i row if if BD = 1
    If Range("BD" & i).Value = "1" Then Rows(i).Select

    'else just copy the current selection
    Selection.Copy
    Sheets("Macro Worksheet 2").Select

    'then paste it into A1 on Macro Sheet 2
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'then find the first empty row on Macro Sheet 2
    Do Until IsEmpty(ActiveCell)
       ActiveCell.Offset(1, 0).Select
    Loop

    'and repaste the copied cells there
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Macro Worksheet").Select
Next i
End Sub

单步执行代码，当 i=2 BD 为空白时，当前选定的 A1 将复制到宏工作表 2 上的 A1 和 A2。

当 i = 3 BD 中有一个 1 时，它会被复制到宏工作表 2 上的 A1 中，然后也粘贴到 A3 中。

依此类推，BD 中有 1 的每一行被复制一次到 A1 中，然后复制到下一个空行中。

所以你需要去掉复制到 A1 中的代码

    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

另一个问题区域在附近

    If Range("BD" & i).Value = "1" Then Rows(i).Select

因为 IF BD 不等于 1，所以无论如何都会执行 IF 语句下方的代码但它会从循环的先前迭代中复制选择（即选择没有改变）：

        'else just copy the current selection
    Selection.Copy
    Sheets("Macro Worksheet 2").Select

    'then find the first empty row on Macro Sheet 2
    Do Until IsEmpty(ActiveCell)
       ActiveCell.Offset(1, 0).Select
    Loop

    'and repaste the copied cells there
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

如果您更改代码以将这些命令放在 IF 语句中，它看起来像这样

Sub FindIssues()
Dim LR As Long, i As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        Sheets("Macro Worksheet").Select

        'Select the i row if if BD = 1
        If Range("BD" & i).Value = "1" Then
            Rows(i).Select
            Selection.Copy
            Sheets("Macro Worksheet 2").Select

            'then find the first empty row on Macro Sheet 2
            Do Until IsEmpty(ActiveCell)
               ActiveCell.Offset(1, 0).Select
            Loop

            'and repaste the copied cells there
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Sheets("Macro Worksheet").Select
        End If
    Next i
End Sub

这可能有点迂腐，但它减少了代码行

• 避免在代码中选择对象；它只会减慢速度！
• 在一行代码上复制/粘贴

这是一种可能的解决方案：

Sub FindIssues()
Dim LR As Long, i As Long
Dim LR2 As String
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LR

        'Test if BD equals 1
        If Range("BD" & i).Value = "1" Then

            'set the next row on Macro Worksheet 2 (assuming no blanks)
            LR2 = WorksheetFunction.CountA(Sheets("Macro Worksheet 2").Range("A:A")) + 1

            'copy row i to the destination
            Rows(i).Copy Sheets("Macro Worksheet 2").Range(LR2 & ":" & LR2)
        End If
    Next i
End Sub

在宏工作表 2 上给出了这个结果