VBA macro: Iterating through all sheets, copying data range based on condition to master sheet

Midday

New Member
Joined
Jul 21, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Context:

I am trying to set up a library of plants in Excel that I can select and see their state throughout the year, so I know what plants to add to make a good-looking garden.
The moment I press the button, that I included in the Master sheet, I want the Master sheet to show the plants I selected in the various other sheets . However, it should only copy some of the cells, as not all info is relevant for the overview.

Problem: I have little experience with excel and none with VBA or macros. I tried various methods/formulas found on the web, but I eventually get stuck because it doesn’t work entirely for what I need, and I miss the knowledge to adapt the code.


What should happen on button press:

  • Clear Master sheet of previous entries starting from A6.
  • Iterate through all the sheets except “Master”.
  • Search each sheet for not empty cells in Column A, starting from row 3 to exclude headers.
    • Column A is used to select plants with x. To be more flexible I’d like the macro to search for any value, hence the not empty/blank.
  • If not empty, then copy column range C to AB from that row to the master sheet.
    • I don't need the selection indicator (column A) or the image (column B) only the rest needs to be copied
I included an example file as well to make it clearer, it has a macro with bits and pieces of code that I collected: https://easyupload.io/893scx

I hope someone can help me out or point me in the right direction.


Thanks in advance for looking at this!
 

Attachments

  • MacroCode.png
    MacroCode.png
    91.9 KB · Views: 24
  • MacroCode.png
    MacroCode.png
    91.9 KB · Views: 24
  • Master-DestinationSheet.png
    Master-DestinationSheet.png
    20.8 KB · Views: 24

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Try:
VBA Code:
Sub CopySelectedPlants()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, x As Long: x = 1
    Set desWS = Sheets("Master")
    With desWS
        .UsedRange.Offset(5).ClearContents
        .UsedRange.Offset(5).Interior.ColorIndex = xlNone
        .Rows.AutoFit
    End With
    For Each ws In Sheets(Array("Perennials", "Trees"))
        With ws
            .ListObjects(x).Range.AutoFilter Field:=1, Criteria1:="<>"
            .AutoFilter.Range.Offset(1, 2).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            .Range("A2").AutoFilter
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
VBA Code:
Sub CopySelectedPlants()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, x As Long: x = 1
    Set desWS = Sheets("Master")
    With desWS
        .UsedRange.Offset(5).ClearContents
        .UsedRange.Offset(5).Interior.ColorIndex = xlNone
        .Rows.AutoFit
    End With
    For Each ws In Sheets(Array("Perennials", "Trees"))
        With ws
            .ListObjects(x).Range.AutoFilter Field:=1, Criteria1:="<>"
            .AutoFilter.Range.Offset(1, 2).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            .Range("A2").AutoFilter
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub
Thanks! It almost works perfectly. The only thing it didn’t copy is info that was in a collapsed group. (Which wasn't clear as it seems I uploaded one image twice instead of the plant sheet -.- )

Because it missed that info it copied the cells in the wrong place in the master sheet, as your code neatly places every cell after one another.

I added the correct image of the perennials sheet, highlighting the group that is normally collapsed which also needs to be copied. I also added an image of the result on the master sheet using the code you provided.


The iterating and filtering works and it also resets the sheet every time the code is run, those parts works great!
 

Attachments

  • Perennials-SourceSheet.png
    Perennials-SourceSheet.png
    249 KB · Views: 19
  • CodeResult.png
    CodeResult.png
    37.3 KB · Views: 16
Upvote 0
Try:
VBA Code:
Sub CopySelectedPlants()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, x As Long: x = 1
    Set desWS = Sheets("Master")
    With desWS
        .Columns("D:F").Cells.EntireColumn.Hidden = False
        .Columns("S:X").Cells.EntireColumn.Hidden = False
        .UsedRange.Offset(5).ClearContents
        .UsedRange.Offset(5).Interior.ColorIndex = xlNone
        .Rows.AutoFit
    End With
    For Each ws In Sheets(Array("Perennials", "Trees"))
        With ws
            .Columns("E").Cells.EntireColumn.Hidden = False
            .Columns("I:T").Cells.EntireColumn.Hidden = False
            .ListObjects(x).Range.AutoFilter Field:=1, Criteria1:="<>"
            .Range("C3", .Range("AB" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            .Range("A2").AutoFilter
            .Columns("E").Cells.EntireColumn.Hidden = True
            .Columns("I:T").Cells.EntireColumn.Hidden = True
        End With
    Next ws
    With desWS
        .Columns("D:F").Cells.EntireColumn.Hidden = True
        .Columns("S:X").Cells.EntireColumn.Hidden = True
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
VBA Code:
Sub CopySelectedPlants()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, x As Long: x = 1
    Set desWS = Sheets("Master")
    With desWS
        .Columns("D:F").Cells.EntireColumn.Hidden = False
        .Columns("S:X").Cells.EntireColumn.Hidden = False
        .UsedRange.Offset(5).ClearContents
        .UsedRange.Offset(5).Interior.ColorIndex = xlNone
        .Rows.AutoFit
    End With
    For Each ws In Sheets(Array("Perennials", "Trees"))
        With ws
            .Columns("E").Cells.EntireColumn.Hidden = False
            .Columns("I:T").Cells.EntireColumn.Hidden = False
            .ListObjects(x).Range.AutoFilter Field:=1, Criteria1:="<>"
            .Range("C3", .Range("AB" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            .Range("A2").AutoFilter
            .Columns("E").Cells.EntireColumn.Hidden = True
            .Columns("I:T").Cells.EntireColumn.Hidden = True
        End With
    Next ws
    With desWS
        .Columns("D:F").Cells.EntireColumn.Hidden = True
        .Columns("S:X").Cells.EntireColumn.Hidden = True
    End With
    Application.ScreenUpdating = True
End Sub
Works like a charm! I have been banging my head against a wall for days, I can't believe you solved it so quickly. Thanks for the help, I highly appreciate it!
 
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,136
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