仅将数据复制到新的工作表，但循环遍历每个工作表

我试图从工作簿中的每张工作表中复制特定的数据，并将其粘贴到另一张工作表上。 每行的行数是不同的，所以我只需要select非空白单元格（并排除导致空格的公式即=“”）。 我也需要它跳过5张，因为这些没有要求的信息。 表格[“摘要模板”，“中国概况”，“中国追踪器”，“活动追踪器”和“PBI数据”]

这是我想要做的：

• 循环通过除上述5之外的每个工作表。 在每个工作表上复制范围（B26：E38）中的所有非空白单元格并将它们粘贴到下一个空白单元格下的“活动数据”工作表。

我试图拼凑一些不同的代码，但没有一个能够一起工作。

请帮忙！

我非常感谢任何帮助，谢谢！

这是我有什么，它运作时，我运行在activesheet，但是当我尝试运行它在所有工作表（每个ws在工作表）我得到一堆错误。

Sub a() Dim LR As Long, cell As Range, rng As Range Dim ws As Worksheets For Each ws In Worksheets With ws LR = ws.Range("B" & Rows.Count).End(xlUp).row If ws.Name <> "SUMMARY TEMPLATE" And ws.Name <> "MILEAGE SUMMARY" And ws.Name <> "MILEAGE TRACKER" _ And ws.Name <> "ACTIVITY TRACKER" And ws.Name <> "PBI DATA" Then For Each cell In .Range("B26:E26" & LR) If cell.Value <> "" Then If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell) End If End If Next cell rng.Select End With Next ws End If End With Next Selection.Copy Sheets("ACTIVITY TRACKER").Select Range("A" & Rows.Count).End(xlUp).Offset(1).Select Selection.PasteSpecial Paste:=xlPasteValues End Sub 

Answer 1

请试试这个代码（你的代码有很多End If ， End With和Next ）：

 Sub a() Dim LR As Long, cell As Range, rng As Range Dim ws As Worksheet For Each ws In Worksheets With ws If .Name <> "SUMMARY TEMPLATE" And .Name <> "MILEAGE SUMMARY" And .Name <> "MILEAGE TRACKER" _ And .Name <> "ACTIVITY TRACKER" And .Name <> "PBI DATA" Then LR = .Range("B" & Rows.Count).End(xlUp).Row For Each cell In .Range("B26:E" & LR) If cell.Value <> "" Then If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell) End If End If Next cell If Not rng Is Nothing Then rng.Copy Sheets("ACTIVITY TRACKER").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues Set rng = Nothing End If End If End With Next ws End Sub 

但是，您不能在不同的工作表上复制多个范围（您需要为每个工作表复制/粘贴）。 它也会出错复杂的select（不能以这种方式复制）

Answer 2

这是你正在尝试？ 如果是，那么让我知道，我会评论代码。

 Option Explicit Dim ws As Worksheet, wsOutput As Worksheet Dim lRow As Long Sub Sample() Dim rngToCopy As Range, aCell As Range Dim Myar As Variant, Ar Set wsOutput = ThisWorkbook.Sheets("Activity Data") For Each ws In ThisWorkbook.Worksheets Select Case UCase(ws.Name) Case UCASE(wsOutput.Name), "SUMMARY TEMPLATE", "MILEAGE SUMMARY", _ "MILEAGE TRACKER", "ACTIVITY TRACKER", "PBI DATA" Case Else lRow = GetLastRow For Each aCell In ws.Range("B26:E38") If aCell.Value <> "" Then If rngToCopy Is Nothing Then Set rngToCopy = aCell Else Set rngToCopy = Union(rngToCopy, aCell) End If End If Next aCell End Select If Not rngToCopy Is Nothing Then For Each Ar In rngToCopy lRow = GetLastRow Ar.Copy wsOutput.Range("A" & lRow) Next Ar Set rngToCopy = Nothing End If Next ws End Sub Function GetLastRow() As Long With wsOutput If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lRow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row + 1 Else lRow = 1 End If End With GetLastRow = lRow End Function