loop through specific sheets and copy entire row into one master sheet if data is in column

[Omer104]

Dear VBA wizards,

Can someone please help me – I have been going through this for a while

I have about 25 sheets in total in an excel file of which 10 sheets (one tab is called is AGV, one other tab is AGR etc) has some data and I would like to copy the entire row in each of these sheets if it has the text “new instrument” in col S, in these 10 sheets there are a lot of rows around 2000

This loop macro would collate all these rows in a sheet called “new instrument”

Can someone please help ?

Thanks a lot,

 

[Joe4]

I have about 25 sheets in total in an excel file of which 10 sheets (one tab is called is AGV, one other tab is AGR etc) has some data and I would like to copy...

How do you differentiate the 10 sheets you want to copy from versus the other 15?
Does this "new instrument" sheet already exist, or does it need to be created first?

 

[Yongle]

Try this which assumes headers are in row1 starting in A1 (if they are you should not need to amend anything except sheet names list)

Amend the 8 sheet names

Sub NewInstrument()
    Dim Ws As Worksheet, w As Variant
    Const List = "[COLOR=#006400][/COLOR]AGV,AGR[COLOR=#ff0000],XX3,XX4,XX5,XX6,XX7,XX8,XX9,X10[/COLOR]"                         
    Application.ScreenUpdating = False
    On Error Resume Next
    Set Ws = Sheets.Add(before:=Sheets(1))
    Ws.Name = "new instrument"
    For Each w In Split(List, ",")
        With Sheets(w)
            .ShowAllData
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="*new instrument*"
            .Rows("2:9999").SpecialCells(xlCellTypeVisible).Copy Ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Rows(1).Copy Ws.Range("A1")
            .ShowAllData
        End With
    Next w
End Sub

 

[My Aswer Is This]

Try using this:

You will see in my example I have used three sheet names.

One Two Three

Modify my names as needed and add more if needed.

Sub Copy_Rows()
'Modified  11/5/2019  10:16:36 AM  EST
Dim i As Long
Dim c As Long
Dim s As Variant
Dim lastrow As Long
Dim Lastrowa As Long
Dim ans As String
c = 19
s = "new instrument"
Lastrowa = Sheets("new instrument").Cells(Rows.Count, c).End(xlUp).Row + 1
For i = 1 To Sheets.Count
Select Case Sheets(i).Name
    Case "One", "Two", "Three" ' Place sheet names here. My example uses names One Two Three. Add more as needed
      ans = Sheets(i).Name
        lastrow = Sheets(ans).Cells(Rows.Count, c).End(xlUp).Row
With Sheets(ans).Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = Sheets(ans).Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("new instrument").Rows(Lastrowa)
        Lastrowa = Sheets("new instrument").Cells(Rows.Count, c).End(xlUp).Row + 1
    
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
        
End Select
       Next
End Sub

 

[Omer104]

Try this which assumes headers are in row1 starting in A1 (if they are you should not need to amend anything except sheet names list)

Amend the 8 sheet names

Sub NewInstrument()
    Dim Ws As Worksheet, w As Variant
    Const List = "AGV,AGR[COLOR=#ff0000],XX3,XX4,XX5,XX6,XX7,XX8,XX9,X10[/COLOR]"                         
    Application.ScreenUpdating = False
    On Error Resume Next
    Set Ws = Sheets.Add(before:=Sheets(1))
    Ws.Name = "new instrument"
    For Each w In Split(List, ",")
        With Sheets(w)
            .ShowAllData
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="*new instrument*"
            .Rows("2:9999").SpecialCells(xlCellTypeVisible).Copy Ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Rows(1).Copy Ws.Range("A1")
            .ShowAllData
        End With
    Next w
End Sub

Thanks a lot i tired to do it for one sheet only (AGV) but its copying all rows even blank ones is it because in the formula in the individual sheet i have a formula that includes New instrument so in AGV tab cell S5 I have =IF(ISNA(E5),"New Instrument","") i then removed all the formulas on AGV and its still copying all the rows onto the new instrument tab

The header is on row 4

 

[Yongle]

Try replacing

            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="*new instrument*"

with
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="New Instrument"

 

[Omer104]

thanks so much for replying but doesnt work either! i even changed the formulas below all the rows except for one to see if it would make a difference but its still picking up all rows

 

[Yongle]

where does your data start?

 

[Omer104]

where does your data start?

Row 4

 

[Yongle]

I have tested with your formula and the filtering works correctly so there is something different in your data structure

after this

            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="New Instrument*"

add this line

            Exit Sub

When you run the macro ...
What is being filtered on the sheet ?
What happens if you click on filter arrow in column S ?
- can you see New Instrument in dropdown list

Are your headers in row 1 ?
Does data start in row 2?