Vba 填写工作簿，而不是一次又一次地覆盖第一个条目

我正在使用以下代码将某些行复制并粘贴到新工作簿中：

Sub ReportCreator()

    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim iCounter As Long
    Dim lrow As Long


    '~~> Source/Input Workbook
    Set wbI = ThisWorkbook
    '~~> Set the relevant sheet from where you want to copy
    Set wsI = wbI.Sheets("Pharmas")

    '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add

lastRow = ThisWorkbook.Worksheets("Pharmas").Cells(Rows.Count, "L").End(xlUp).Row


    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file

        For iCounter = 2 To lastRow
        If wsI.Cells(iCounter, 4) = "Barr" Then
        wsI.Rows(iCounter).Copy
        End If

        wsO.Range("A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

        Next iCounter

.SaveAs Filename:="C:\Users\rrrrr\Desktop\eeee.xls", FileFormat:=56
       End With




End Sub

当代码进入我的列表时，将复制第4列中带有Barr的任何行，然后粘贴到新工作簿上

我遇到的问题是，它没有为找到的每一行粘贴新工作簿。而在新工作簿上，它只是用更新的信息覆盖第一行。当我调试时，查找Barr并复制行的代码部分工作正常，但它并没有粘贴工作簿，只是覆盖了第一行

我尝试添加粘贴代码，如下所示：

wsI.Rows(iCounter).Copy
            End If
lrow = Range("A" & .Rows.Count).End(xlUp).Row
            wsO.Range("A" & lrow + 1).PasteSpecial Paste:=xlPasteValues, 

但是，它告诉我对象不支持此属性或方法

---

我确信粘贴代码是不正确的，但我不确定如何更改它，使其填充工作簿，而不是在每次后续找到Barr时反复覆盖第一个条目。

在您的解决方案中，您忘记引用wsO:

lrow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row
wsO.Range("A" & lrow + 1).PasteSpecial Paste:=xlPasteValues

这个解决方案应该是可行的，但应该是缓慢的。通过跟踪变量中的下一行并在粘贴行时对其进行校正，可以加快运行速度

试试这个修改后的代码

Sub OhYa()
    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim iCounter As Long
    Dim lrow As Long, rw As Long


    '~~> Source/Input Workbook
    'Set wbI = ThisWorkbook
    '~~> Set the relevant sheet from where you want to copy
    Set wsI = Sheets("Pharmas")

    '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add

    lastRow = wsI.Cells(Rows.Count, 4).End(xlUp).Row


    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file
        With wsI
            For iCounter = 2 To lastRow
                If wsI.Cells(iCounter, 4) = "Barr" Then
                    .Cells(iCounter, 4).EntireRow.Copy
                    rw = wsO.Cells(wsO.Rows.Count, "A").End(xlUp).Row + 1
                    wsO.Cells(rw, 1).PasteSpecial Paste:=xlPasteValues

                End If

            Next iCounter

            '.SaveAs Filename:="C:\Users\rrrrr\Desktop\eeee.xls", FileFormat:=56
        End With
    End With

    Application.CutCopyMode = 0

End Sub

---

如果只需要值，则不要使用“粘贴”，而是直接将值指定给单元格

lrow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row
wsO.rows(lrow + 1).value =wsI.Rows(iCounter).value

---

当我尝试用上面的修改运行它时，我得到了一个特殊的range类方法失败错误谢谢@Scott Craner！这很好用。我最终使用了DaveExcel代码，因为我意识到我确实需要单元格格式，而不仅仅是值