copy data only cells to new worksheet but cycle through each worksheet

Question

I am trying to copy specific data from each sheet in a workbook and paste it on a different sheet one after another. The number of rows is different on each sheet so i need to select only non-blank cells (and exclude formulas that result in blanks ie=""). I also need it to skip over 5 sheets as these do not have the info being requested. Sheets["SUMMARY TEMPLATE", "MILEAGE SUMMARY", "MILEAGE TRACKER", "ACTIVITY TRACKER", and "PBI DATA"]

Here is what I'd like to do:

• Loop through each worksheet except the 5 above. On each worksheet, copy all non-blank cells in range(B26:E38) and paste them on the "Activity Data" Sheet under the next blank cell.

I have tried to piece together a few different codes but none of them work together.

Please help!

I really appreciate any help, thanks!!

Here is what i have, it works when i run it on the activesheet but when i try to run it on all sheets (For each ws in Worksheets) I get a bunch of errors.

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

pls try this code (your code has to many End If, End With and 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

still, you can not copy multiple ranges over different worksheets (you need to copy/paste it for each sheet). It will also error out for complex selectings (which cannot be copied in that way)

Answer 2

Is this what you are trying? If yes, then let me know and I will comment the code.

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