将多个工作表中的行复制到一个工作表中

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