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

I am struggling with a bit of code that is getting stuck in a loop. I am trying to get the code to copy any rows where the values in column BD is 1 and paste the values for that entire row in to the next empty row in another worksheet. The code i am using is as below

我正在努力处理一些陷入循环的代码。我试图让代码复制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

Thanks for your help

谢谢你的帮助

2 个解决方案

#1

Macro Worksheet

宏工作表

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

Macro Worksheet 2

宏工作表2

#2

I've replicated your 2 sheets with column A on Macro Worksheet containing

我在包含的Macro Worksheet上用A列复制了你的2张纸

and column BD containing 1s in rows 3 and 5

和列BD在行3和5中包含1

So I expect rows 3 and 5 to copy to rows 1 and 2 of Macro Worksheet 2.

所以我希望第3行和第5行复制到Macro Worksheet 2的第1行和第2行。

When I run FindIssues with a blank cell A1 selected on macro Worksheet I get the unexpected result of

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

If you look at and step through your code (reformatted and commented):

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

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

Stepping through the code, when i=2 BD is blank the currently selected A1 is copied to A1 and A2 on Macro Worksheet 2.

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

When i = 3 BD has a 1 in it so it gets copied to A1 on Macro Worksheet 2 and then pasted into A3 as well.

当i = 3时，BD中有一个1，因此它将被复制到Macro Worksheet 2上的A1，然后粘贴到A3中。

And so on it goes with each row having 1 in BD being copied once into A1 and then into the next empty row.

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

So you need to get rid of the code that copies into A1

所以你需要摆脱复制到A1的代码

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

The other problem area is around

另一个问题是围绕着

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

because IF BD doesn't equal 1, the code below your IF statement is executed anyway but it copies the selection from the prior iteration of the loop (i.e. the selection hasn't changed):

因为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 you change your code to put those commands within the IF statement it looks like this

如果更改代码以将这些命令放在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

It's probably a bit pedantic but it reduces the code lines

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

• avoid selecting objects in your code; it just slows things down!
• 避免在代码中选择对象;它只会减慢速度！
• do copy/paste on one line of code
• 复制/粘贴一行代码

and this is one possible solution:

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

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

Which gives this result On Macro Worksheet 2

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