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

[Natman111]

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]

This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

 

[vcoolio]

Hello Natman,

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

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]

Hello Natman,

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

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]

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

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]

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

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]

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.

 

[Natman111]

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]

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.

11 TEST 280421.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

 

[vcoolio]

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.

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]

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.

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.