Copy specific cells from multiple worksheets in VBA

[JorgenKjer]

Hallo

Cananyone help me?

I have aworkbook with multiple worksheets
One worksheetcalled “Search” is where data need to be past to.
Allother worksheets have filter buttons that if in use needs resetting, show alldata, before start searching for data.
Worksheet“Search” needs to be deleted of all data from previous run from row 2 and down
New Datawill be past to row 2 and down
The codeneeds to loop through all worksheets and copy rows that meets criteria “XX.XX”in column C
Onlycells in Columns A, C, D, E, H in matching rows shall be past to worksheet “Search”
I hopeall this makes sense.
I willbe grateful if anyone can help me.

Yourssincerely
JorgenKjer

 

[vcoolio]

Hello Jorgen,

Well your workbook needs to be tidied up somewhat but below is a code that will do as you would like:-

Sub Test()

        Dim ws As Worksheet
        Dim sht As Worksheet: Set sh = Sheets("Search")
        Dim lr As Long, lr1 As Long
        Dim dSearch As String
        dSearch = Sheets("Search").[F1].Value
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        
Application.ScreenUpdating = False

With sh
    If lr > 1 Then sh.Range("A2:X" & lr).Clear
End With

For Each ws In Worksheets
             If ws.Name <> "Search" And ws.Name <> "Data" Then
             ws.Range("C1", ws.Range("C" & ws.Rows.Count).End(xlUp)).AutoFilter 1, dSearch
             lr1 = ws.Range("A" & Rows.Count).End(xlUp).Row
             If lr1 > 1 Then
             Union(ws.Range("A2:A" & lr1), ws.Range("C2:E" & lr1), ws.Range("H2:H" & lr1)).Copy
             sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
             ws.[C1].AutoFilter
             End If
       End If
Next ws

        sh.Range("A2:X" & lr).WrapText = False
        sh.Columns.AutoFit
        sh.Rows.AutoFit
        sh.Rows(1).RowHeight = 28
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Here are some of the things you need to do to help tidy up your workbook:-

- Go through each sheet and unmerge all merged cells. Merged cells create havoc with VBA codes. You can easily re-format your worksheets without merged cells.
- In sheet 540_8, delete Row1 (unmerge cells first).
- In some of the source worksheets, Column H is completely blank. In your opening post you said that you require Column H data to be transferred to the "Search" sheet along with Columns A and C:E. Fill in Column H (from Column G?) data.

Following is the link to your sample file with the code implemented and assigned to the "Opdater" button. I have carried out the above steps for you in the sample.

http://ge.tt./5gqYb5x2

You will also note that I have moved the search cell from the "Data" sheet to the "Search" sheet in cell F1. I thought it would be a tidier method to have the search cell directly in your line of sight. Hence, once you select a criteria from the drop down in cell I1, the criteria code will immediately show in F1 and when you click on the "Opdater" button, all the relevant rows of data from the source sheets will be transferred to the "Search" sheet.

Test all this in a copy of your workbook just so that you can be sure that this is how you want it to work.

I hope that this helps.

Cheerio,
vcoolio.

 

[JorgenKjer]

Thanks again for the help, I have some questions in a Word document as well as an updated workbook that can be downloaded from this link.


Many greetings
Jorgen Kjer

https://www.dropbox.com/s/5x9cpyio3vkyhgn/Udkast pmp layout_ver.3.xlsm?dl=0

 

[vcoolio]

Hello Jorgen,

I don't see a Word document and the workbook is the same as the last! Does the information in post #11 not work?

Cheerio,
vcoolio.

 

[JorgenKjer]

Hi Vcoolio

I ope i Works this time

https://www.dropbox.com/s/pssbv4dpheiuxl0/Mr%20Excel.docx?dl=0
https://www.dropbox.com/s/8hm3y3isbvjp8w1/Udkast%20pmp%20layout_ver.4.xlsm?dl=0

 

[vcoolio]

Hello Jorgen,

Thanks for that. The code amended as follows should cover all your questions:-

Sub Test()

        Dim ws As Worksheet
        Dim sht As Worksheet: Set sh = Sheets("Search")
        Dim lr As Long, lr1 As Long
        Dim dSearch As String
        dSearch = sh.[F1].Value
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        
Application.ScreenUpdating = False

With sh
    If lr > 1 Then sh.Range("A2:X" & lr).Clear
End With

For Each ws In Worksheets
             If ws.Name <> "Search" And ws.Name <> "Data" Then
            [COLOR=#ff0000] If ws.AutoFilterMode = True Then ws.AutoFilterMode = False[/COLOR]
             ws.Range("C1", ws.Range("C" & ws.Rows.Count).End(xlUp)).AutoFilter 1, dSearch
             lr1 = ws.Range("A" & Rows.Count).End(xlUp).Row
             If lr1 > 1 Then
             Union(ws.Range("A2:A" & lr1), ws.Range("C2:E" & lr1), ws.Range("H2:H" & lr1)).Copy
             sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial [COLOR=#ff0000]xlPasteAll[/COLOR]
             End If
             ws.[C1].AutoFilter
             [COLOR=#ff0000]ws.[A1].AutoFilter[/COLOR]
       End If
Next ws

        sh.Columns.AutoFit
        sh.Rows.AutoFit
        sh.Rows(1).RowHeight = 28
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

The bits in red font are the amendments.

Let me know how it works out for you.

Cheerio,
vcoolio.

 

[JorgenKjer]

HiVcoolio

It isabsolutely fantastic. I am very grateful for all your help and patience.


However,there is a funny thing, on sheet 30_12, part of the check boxing disappearsfrom the filter when the code have run, do you have any idea why?

If, afterthe code have run, I select all data on sheet 30_12 and remove filter andreinstall the filter, all check boxes reapper. Maybe it's something to do withthe formatting of this sheet, as it doesn't happen on any of the other sheetsin this workbook. Very strange.


Butaway, apart from this little matter, your code does a 100% what I wanted

Thankyou very much

Manygreetings
Jørgen Kjer

 

[vcoolio]

Hello Jorgen,

You're welcome. I'm glad to have been able to assist.

I have come across that little problem that you mentioned above in the past. It seems to randomly appear and usually is caused by:-
- blank cells/rows which the filter list doesn't pick up on.
- Merged column headings.
- Having more than one row of Column headings. The filter will only work on one row.
- Exceeding the filter list limits.

However, in your case, we can try an reset the filter lists with each pass of the code. The code amended as follows should do the trick for you:-

Sub Test()

        Dim ws As Worksheet
        Dim sht As Worksheet: Set Sh = Sheets("Search")
        Dim lr As Long, lr1 As Long
        Dim dSearch As String
        dSearch = Sh.[F1].Value
        lr = Sh.Range("A" & Rows.Count).End(xlUp).Row
        
Application.ScreenUpdating = False

With Sh
    If lr > 1 Then Sh.Range("A2:X" & lr).Clear
End With

For Each ws In Worksheets
             If ws.Name <> "Search" And ws.Name <> "Data" Then
             If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
             ws.Range("C1", ws.Range("C" & ws.Rows.Count).End(xlUp)).AutoFilter 1, dSearch
             lr1 = ws.Range("A" & Rows.Count).End(xlUp).Row
             If lr1 > 1 Then
             Union(ws.Range("A2:A" & lr1), ws.Range("C2:E" & lr1), ws.Range("H2:H" & lr1)).Copy
             Sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
             End If
             ws.[C1].AutoFilter
            [COLOR=#ff0000] With ws.Range("A1:Z" & lr1)
             .AutoFilter
             End With[/COLOR]
       End If
Next ws

        Sh.Columns.AutoFit
        Sh.Rows.AutoFit
        Sh.Rows(1).RowHeight = 28
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

I've removed this line from the previous code:-

ws.[A1].Autofilter

and added the bit in red font above.

Let me know if this works for you.

Cheerio,
vcoolio.

 

[JorgenKjer]

HiVcoolio



It didthe trick, many thanks



In mycountry we have a saying, if you reach out they take the whole arm. I feel I amdoing it now.



I shouldhave thought of it earlier.



However,it is possible if in the Drop Down list add a search criterion called"All" can copy all rows in all sheets that are not blank in column Cand transfer the data to sheets "Search" still only data that is in thecolumns as is being transferred now?



Afterdata is transferred to sheet "Search", data in column B in sheet"Search" must be sorted from 01.00 to 08.10.



Anotheroption is not to add “All” to the Drop Down list but just have an extra macrobutton that runs a code that performs the task.



Greetings

Jørgen

 

[vcoolio]

Hello Jorgen,

Another option is not to add “All” to the Drop Down list but just have an extra macro button that runs a code that performs the task.

I've attached a link to your workbook as follows:-

http://ge.tt./36bIY6x2

just because I've made a couple of changes to the "Search" sheet (its up to you if you like it!). I've done this mainly so that we can keep everything (mostly) in the main view without having to scroll to the buttons.

I've added a separate code to perform the All Data search and assigned it to the "All Data" button. Here's the code:-

Sub AllData()

        Dim ws As Worksheet
        Dim sht As Worksheet: Set Sh = Sheets("Search")
        Dim lr As Long, lr1 As Long
        lr = Sh.Range("A" & Rows.Count).End(xlUp).Row
        
Application.ScreenUpdating = False

With Sh
    If lr > [COLOR=#ff0000]2[/COLOR] Then Sh.Range("[COLOR=#ff0000]A3[/COLOR]:X" & lr).Clear
End With

For Each ws In Worksheets
             If ws.Name <> "Search" And ws.Name <> "Data" Then
             If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
             ws.Range("C1", ws.Range("C" & ws.Rows.Count).End(xlUp)).AutoFilter 1, [COLOR=#ff0000]"<>" & "" [/COLOR]
             lr1 = ws.Range("A" & Rows.Count).End(xlUp).Row
             If lr1 > 1 Then
             Union(ws.Range("A2:A" & lr1), ws.Range("C2:E" & lr1), ws.Range("H2:H" & lr1)).Copy
             Sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
             [COLOR=#ff0000]Sh.Range("A3", Sh.Range("E" & Sh.Rows.Count).End(xlUp)).Sort Sh.[B3], 1  [/COLOR]'---->Sorts on Column B.[COLOR=#ff0000][/COLOR]
             End If
             ws.[C1].AutoFilter
             With ws.Range("A1:Z" & lr1)
             .AutoFilter
             End With
       End If
Next ws
        
        Sh.Columns.AutoFit
        Sh.Rows.AutoFit
        Sh.Rows([COLOR=#ff0000]"1:2"[/COLOR]).RowHeight = 26
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

The code is pretty well the same as the first one except for the minor changes which I've marked in red font. It will transfer all rows of data from each source sheet where the criteria cell in Column C is not blank.

Now, I've altered the code in post #17 a little as well just to accommodate the different set up of the "Search" sheet:-

Sub Test()

        Dim ws As Worksheet
        Dim sht As Worksheet: Set Sh = Sheets("Search")
        Dim lr As Long, lr1 As Long
        Dim dSearch As String
       [COLOR=#ff0000] dSearch = Sh.[F2].Value[/COLOR]
        lr = Sh.Range("A" & Rows.Count).End(xlUp).Row
        
Application.ScreenUpdating = False

With Sh
    If lr > [COLOR=#ff0000]2[/COLOR] Then Sh.Range("[COLOR=#ff0000]A3[/COLOR]:X" & lr).Clear
End With

For Each ws In Worksheets
             If ws.Name <> "Search" And ws.Name <> "Data" Then
             If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
             ws.Range("C1", ws.Range("C" & ws.Rows.Count).End(xlUp)).AutoFilter 1, dSearch
             lr1 = ws.Range("A" & Rows.Count).End(xlUp).Row
             If lr1 > 1 Then
             Union(ws.Range("A2:A" & lr1), ws.Range("C2:E" & lr1), ws.Range("H2:H" & lr1)).Copy
             Sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
             End If
             ws.[C1].AutoFilter
             With ws.Range("A1:Z" & lr1)
             .AutoFilter
             End With
       End If
Next ws

        Sh.Columns.AutoFit
        Sh.Rows.AutoFit
        Sh.Rows([COLOR=#ff0000]"1:2"[/COLOR]).RowHeight = 26
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

You should be on the straight and narrow now!

Cheerio,
vcoolio.

 

[JorgenKjer]

Hi Vcoolio

Thanks again for your great help. It works perfectly


Regards
Jørgen