Copying rows from multiple worksheets onto one worksheet based on the contents in one cell

[kinnoyu]

I've been having a bit of trouble trying to get some code to work. I have a workbook with multiple sheets. Each sheets has a bunch of rows of data, and I want to organize the data onto specific sheets based on the contents in one cell. So any of the rows that have the word "BASE" in the A column from all worksheets I want copied onto a sheet named BASE.

Here's what I have so far

Sub NewSheetData()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ws As Worksheet
Dim Rng As Range

For Each ws In ThisWorkbook.Worksheets

Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp))

On Error Resume Next
    With Rng
        .AutoFilter , field:=1, Criteria1:="BASE"
        .SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("BASE").Range("A1").Offset(n, 0)
        n = n + 1
        
        .AutoFilter
    End With
On Error GoTo 0

Next ws

Application.EnableEvents = True


End Sub

It runs fine when I remove the "For Each, Next" code which I added to try and make it run through all the worksheets. Then it won't do anything at all; it won't give me an error, it just won't do anything.

 

[jolivanes]

Try

Sub Maybe()
Dim i As Long
Application.ScreenUpdating = False
    For i = 1 To ThisWorkbook.Worksheets.Count
        If Sheets(i).Name <> "BASE" Then
            If WorksheetFunction.CountIf(Sheets(i).Columns(1), "BASE") <> 0 Then
                With Sheets(i).UsedRange
                    .AutoFilter 1, "BASE"
                        .Offset(1).Copy Sheets("BASE").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    .AutoFilter
                End With
            End If
        End If
    Next i
Application.ScreenUpdating = True
End Sub

 

[Fluff]

Another option

Sub NewSheetData()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ws As Worksheet
Dim Rng As Range

For Each ws In ThisWorkbook.Worksheets
   If UCase(ws.Name) <> "BASE" Then
      Set Rng = ws.Range([A1], ws.Range("A" & Rows.Count).End(xlUp))
      
      On Error Resume Next
          With Rng
              .AutoFilter , field:=1, Criteria1:="BASE"
              .Parent.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets("BASE").Range("A" & Rows.Count).End(xlUp).Offset(1)
              .AutoFilter
          End With
      On Error GoTo 0
   End If
Next ws

Application.EnableEvents = True


End Sub