仅将数据单元格复制到新工作表，但循环浏览每个工作表

Question

我正在尝试从工作簿中的每个工作表中复制特定数据，并将其逐个粘贴到不同的工作表上。每张纸上的行数不同，因此我只需要选择非空白单元格（并排除导致空白的公式，即 =“”）。我还需要它跳过 5 张纸，因为它们没有请求的信息。表格[“SUMMARY TEMPLATE”、“MILEAGE Summary”、“MILEAGE TRACKER”、“Activity TRACKER”和“PBI DATA”]

这是我想做的：

• 遍历除上述 5 之外的每个工作表。 在每个工作表上，复制范围 (B26:E38) 中的所有非空白单元格并将它们粘贴到下一个空白单元格下的“活动数据”表上。

我尝试将几个不同的代码拼凑在一起，但没有一个可以一起工作。

请帮忙！

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

这就是我所拥有的，当我在活动表上运行它时它可以工作，但是当我尝试在所有工作表上运行它时（对于工作表中的每个 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

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

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