将多张纸中的行复制到一张纸中

Question

Public Sub SubName()
Dim ws As Worksheet
Dim iCounter As Long
Dim wso As Worksheet
Dim rw As Long
Dim lastrow As Long

Set wso = Sheets("Master")

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "*" & "danger" & "*" Then
    ws.Select
    lastrow = ws.Cells(Rows.Count, 4).End(xlUp).Row
            For iCounter = 2 To lastrow
                If ws.Cells(iCounter, 8) < 0.15 And ws.Cells(iCounter, 8) > -0.1 Then

                    ws.Cells(iCounter, 8).EntireRow.Copy

                    rw = wso.Cells(wso.Rows.Count, "A").End(xlUp).Row + 1
                    wso.Cells(rw, 1).PasteSpecial Paste:=xlPasteAll

                End If
            Next iCounter

    End If
Next ws
End Sub

这是代码的作用：

1. 浏览所有工作表，找到带有文字“危险”的工作表
2. 对于名为“ danger *”的工作表，请遍历H列，如果符合条件，请复制整行
3. 将整行粘贴到主表上

我认为代码可以正常工作，直到我需要将其粘贴到主表上为止。 我得到的问题是，它只是粘贴到主表的同一行上，而不是行+1。

最终结果是在母版纸上仅显示一行，这是要粘贴的迭代的最后一行。

任何帮助表示赞赏！

Answer 1

尝试执行以下操作将行从一个工作表复制到另一工作表（每行在不同行）：

Dim i, lastRow as Integer

Dim wso, ws, copyFrom as Worksheet

Set wso = Sheets("Master")

For Each ws In ActiveWorkbook.Worksheets

If ws.Name Like "*" & "danger" & "*" Then

    copyFrom =  ws.Select

End if


lastRow = Sheets(copyFrom).Range("A" & Rows.Count).End(xlUp).Row
For i=1 to lastRow

If <--your criteria--> then

    ThisWorkbook.Sheets(copyFrom).Rows(i).EntireRow.Copy Destination:=ThisWorkbook.Sheets(wso).Rows(i)

End if

Next i
Next ws