Copy rows from one sheet to another based on text in one cell.

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows
I have a spreadsheet with multiple worksheets. I would like to automatically copy rows that are based on a criteria in Column A in all worksheets and then paste in one "Master" Sheet, then repeat for another criteria. Eg. I have 5 sheets, and in Column A in each I am wanting to find the text "MD2" then copy and paste the entire row into "Master" Sheet (on the next available row) - there could be 10 rows per sheet that could met this criteria. Then once this criteria has been completed repeat however this time look for the text "BM2". Hopefully that makes sense. Thank you in advance.
 

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
17,556
Office Version
  1. 2013
Platform
  1. Windows
This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Natman,

This could(?) work for you (untested):-

VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, ar As Variant, wsM As Worksheet, i As Long
        Dim sVal1 As String, sVal2 As String
        Set wsM = Sheets("Master")
        sVal1 = wsM.[J1].Value
        sVal2 = wsM.[Q1].Value
        ar = Array(sVal1, sVal2)
       
Application.ScreenUpdating = False
       
        wsM.UsedRange.Offset(1).Clear
        For i = 0 To UBound(ar)
                For Each ws In Worksheets
                        If ws.Name <> "Master" Then
                                With ws.[A1].CurrentRegion
                                        .AutoFilter 1, ar(i), 7
                                        .Offset(1).Copy wsM.Range("A" & Rows.Count).End(3)(2)
                                        .AutoFilter
                                End With
                                On Error Resume Next
                                wsM.Columns(1).SpecialCells(4).EntireRow.Delete
                                On Error GoTo 0
                        End If
                Next ws
        Next i

Application.ScreenUpdating = True

End Sub

It should allow for a "mix and match" selection from the two drop downs. Let us know what you think.

Cheerio,
vcoolio.
 

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows
Hello Natman,

This could(?) work for you (untested):-

VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, ar As Variant, wsM As Worksheet, i As Long
        Dim sVal1 As String, sVal2 As String
        Set wsM = Sheets("Master")
        sVal1 = wsM.[J1].Value
        sVal2 = wsM.[Q1].Value
        ar = Array(sVal1, sVal2)
      
Application.ScreenUpdating = False
      
        wsM.UsedRange.Offset(1).Clear
        For i = 0 To UBound(ar)
                For Each ws In Worksheets
                        If ws.Name <> "Master" Then
                                With ws.[A1].CurrentRegion
                                        .AutoFilter 1, ar(i), 7
                                        .Offset(1).Copy wsM.Range("A" & Rows.Count).End(3)(2)
                                        .AutoFilter
                                End With
                                On Error Resume Next
                                wsM.Columns(1).SpecialCells(4).EntireRow.Delete
                                On Error GoTo 0
                        End If
                Next ws
        Next i

Application.ScreenUpdating = True

End Sub

It should allow for a "mix and match" selection from the two drop downs. Let us know what you think.

Cheerio,
vcoolio.
Wow looking good - Just one wee problem it is pasting into row one so I am losing the drop down lists in row 1 and the headers in row 2
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Natman,

I've just had a look at the images you posted and it appears that in the Master sheet we need to be pasting to Column B not Column A as in the code.
Hence, try the code amended as follows:-

VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, ar As Variant, wsM As Worksheet, i As Long
        Dim sVal1 As String, sVal2 As String
        Set wsM = Sheets("Master")
        sVal1 = wsM.[J1].Value
        sVal2 = wsM.[Q1].Value
        ar = Array(sVal1, sVal2)
        
Application.ScreenUpdating = False
        
        wsM.UsedRange.Offset(1).Clear
        For i = 0 To UBound(ar)
                For Each ws In Worksheets
                        If ws.Name <> "Master" Then
                                With ws.[A1].CurrentRegion
                                        .AutoFilter 1, ar(i), 7
                                        .Offset(1).Copy wsM.Range("B" & Rows.Count).End(3)(2)
                                        .AutoFilter
                                End With
                                On Error Resume Next
                                wsM.Columns(2).SpecialCells(4).EntireRow.Delete
                                On Error GoTo 0
                        End If
                Next ws
        Next i

Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.
 

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hello Natman,

I've just had a look at the images you posted and it appears that in the Master sheet we need to be pasting to Column B not Column A as in the code.
Hence, try the code amended as follows:-

VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, ar As Variant, wsM As Worksheet, i As Long
        Dim sVal1 As String, sVal2 As String
        Set wsM = Sheets("Master")
        sVal1 = wsM.[J1].Value
        sVal2 = wsM.[Q1].Value
        ar = Array(sVal1, sVal2)
       
Application.ScreenUpdating = False
       
        wsM.UsedRange.Offset(1).Clear
        For i = 0 To UBound(ar)
                For Each ws In Worksheets
                        If ws.Name <> "Master" Then
                                With ws.[A1].CurrentRegion
                                        .AutoFilter 1, ar(i), 7
                                        .Offset(1).Copy wsM.Range("B" & Rows.Count).End(3)(2)
                                        .AutoFilter
                                End With
                                On Error Resume Next
                                wsM.Columns(2).SpecialCells(4).EntireRow.Delete
                                On Error GoTo 0
                        End If
                Next ws
        Next i

Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.
Sorry no - it continues to overwrite. I also end up with another problem if I have insert rows above the data in sheet U1 into row 1 ie move the data down say 5 rows. I get the error 400 for some reason.
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Natman,

Not sure why its happening but I feel that you have a number of merged cells which will cause no end of problems for VBA codes so the best option here is for you to upload a sample of your workbook to a file sharing site such as Drop Box or WeTransfer then paste the link to your file back here. Testing on a sample will make it a lot simpler to solve this for you.
Make sure that the sample is an exact replica of your actual workbook and if your data is sensitive then please use dummy data.

The 400 error would be caused by the fact that you have new rows inserted above the data (I'm assuming above the headings). This will in turn render the CurrentRegion inoperable so we may have to look at an alternative to this should you absolutely need to insert new rows.

Cheerio,
vcoolio.
 
Last edited:

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Link 11 TEST 280421.xlsm

Right here is the file. In Master I would like to pick from the dropdown lists and then have the the matching data copied into the master sheet ie if I pick U2 from cell "M2" then cell "R2" would return the info that I want to search the other sheets - in this case "MD2". I would also like if I pick PL2 or ST2 or EL2 that it copies PL2 and LIA2 as an example.
 

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows
Link 11 TEST 280421.xlsm

Right here is the file. In Master I would like to pick from the dropdown lists and then have the the matching data copied into the master sheet ie if I pick U2 from cell "M2" then cell "R2" would return the info that I want to search the other sheets - in this case "MD2". I would also like if I pick PL2 or ST2 or EL2 that it copies PL2 and LIA2 as an example.
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,079
Hello Natman,

This is confusing and considerably different from your opening few posts. You no longer have J1 and Q1 as the drop downs as previously stated but have a number of drop downs in ranges("M2:M7") and "X2:X7" with the criteria (Columns R and AC) calculated by a formula.

Before we take this any further, test the following code for yourself to see if the results are what you were hoping for. Please note that, for now, it is hard coded to work only on M2 and R2. Change the values in both ranges a number of times to satisfy yourself that the results are correct.
VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, wsM As Worksheet
        Dim sVal As String
        Set wsM = Sheets("Master")
        Set ws = Sheets(Range("M2").Value) '---->Hard coded for now.
        sVal = wsM.[R2].Value  '---->Hard coded for now.
       
Application.ScreenUpdating = False
       
        wsM.[A12].CurrentRegion.Offset(1).Clear

        With ws.[A12].CurrentRegion
                .AutoFilter 1, sVal
                .Offset(1).Copy wsM.Range("B" & Rows.Count).End(3)(2)
                .AutoFilter
        End With

Application.ScreenUpdating = True

End Sub


In each of the source sheets (U1-->U5), you will need to place a heading of some sort (perhaps "Criteria"?) in cell A12 to ensure that the filter works correctly. DO NOT leave it blank.

Let us know what you think.

Cheerio,
vcoolio.
 

Natman111

New Member
Joined
Apr 26, 2021
Messages
14
Office Version
  1. 365
Platform
  1. Windows
Hello Natman,

This is confusing and considerably different from your opening few posts. You no longer have J1 and Q1 as the drop downs as previously stated but have a number of drop downs in ranges("M2:M7") and "X2:X7" with the criteria (Columns R and AC) calculated by a formula.

Before we take this any further, test the following code for yourself to see if the results are what you were hoping for. Please note that, for now, it is hard coded to work only on M2 and R2. Change the values in both ranges a number of times to satisfy yourself that the results are correct.
VBA Code:
Option Explicit
Sub Test()

        Dim ws As Worksheet, wsM As Worksheet
        Dim sVal As String
        Set wsM = Sheets("Master")
        Set ws = Sheets(Range("M2").Value) '---->Hard coded for now.
        sVal = wsM.[R2].Value  '---->Hard coded for now.
      
Application.ScreenUpdating = False
      
        wsM.[A12].CurrentRegion.Offset(1).Clear

        With ws.[A12].CurrentRegion
                .AutoFilter 1, sVal
                .Offset(1).Copy wsM.Range("B" & Rows.Count).End(3)(2)
                .AutoFilter
        End With

Application.ScreenUpdating = True

End Sub


In each of the source sheets (U1-->U5), you will need to place a heading of some sort (perhaps "Criteria"?) in cell A12 to ensure that the filter works correctly. DO NOT leave it blank.

Let us know what you think.

Cheerio,
vcoolio.
Yes sorry I made some changes as I needed to change some things around. Also a big thanks for your help on this. Ran the code, had to change [A12] to [A13] so the header was not copied. Then when I first run the code for each [R2] criteria I got all of the rows however if I repeat then it works great. Thank you looking good.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,468
Messages
5,636,492
Members
416,919
Latest member
twc2c

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
Top