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

Omer104

New Member
Joined
Oct 5, 2015
Messages
13
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

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
51,128
Office Version
365
Platform
Windows
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?
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,238
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

Code:
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

Well-known Member
Joined
Jul 5, 2014
Messages
16,033
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.


Code:
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

New Member
Joined
Oct 5, 2015
Messages
13
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

Code:
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

Well-known Member
Joined
Mar 11, 2015
Messages
4,238
Try replacing
Code:
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="*new instrument*"
Code:
with
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="New Instrument"
 

Omer104

New Member
Joined
Oct 5, 2015
Messages
13
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

Well-known Member
Joined
Mar 11, 2015
Messages
4,238
I have tested with your formula and the filtering works correctly so there is something different in your data structure

after this
Code:
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="New Instrument*"
add this line
Code:
            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?
 
Last edited:

Forum statistics

Threads
1,077,686
Messages
5,335,656
Members
399,032
Latest member
thefinu

Some videos you may like

This Week's Hot Topics

Top