在列中搜索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

我在包含

的宏工作表上用A列复制了2张纸

和BD行第3行和第5行包含1s

所以我希望第3行和第5行复制到Macro Worksheet 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，因此它会被复制到Macro Worksheet 2上的A1，然后再粘贴到A3中。

依此类推，BD中的每一行都会被复制一次到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

在Macro Worksheet 2中给出了这个结果