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
42
Office Version
  1. 365
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,
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Try replacing
Code:
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="*new instrument*"
Code:
with
            .Range("A1:ZZ9999").AutoFilter Field:=19, Criteria1:="New Instrument"
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,142
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top