將數據僅復制到新工作表但循環遍歷每個工作表

Question

我試圖從工作簿中的每個工作表中復制特定數據，並將其粘貼在不同的工作表上。 每張紙上的行數不同，因此我只需要選擇非空白單元格（並排除導致空白的公式，即=“ =”）。 我還需要它跳過超過5張，因為這些沒有要求的信息。 表格[“摘要模板”，“遷移摘要”，“遷移跟蹤器”，“活動跟蹤器”和“ PBI數據”]

這是我想做的：

• 循環瀏覽除上面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