Modular spreadsheet to reduce re-work

[ea123]

Good day:

I have a spreadsheet with multiple tabs. On the same spreadsheet, I have a worksheet called "List". List has names of several tabs in column A. I am using the following code to copy various tabs, in a sequential order, as listed in Worksheet "List" to another worksheet called "Consolidate", all within the same spreadsheet.

I want to enhance this code, so I can:

1. Have multiple list tabs, lets say List1, List 2 and List3 and copies the tabs listed in those lists, in sequential order and pastes those in another Spreadsheet.
2. The other spreadsheet will create a tab each for List1, List2, List3. Each one of these tabs will be copied from the other spreadsheet as defined in List1, List2, List 3 etc...

The intent behind this is to minimize the maintenance on tabs that are listed in List1, List2, lIST3. Wherever those tabs change, I want to run this code and copy paste the new content and reduce the work of copying-pasting multiple times. Hope it makes sense!

Appreciate the help! Thanks.

Option Explicit
Sub Consolidate()

    'Dim i As Integer
    Dim w As Worksheet
    Dim rngMyCell As Range
    Dim lngLastRow As Long
    
    On Error Resume Next
        Sheets(1).Select
        Worksheets.Add ' add a worksheet for consolidation of other tabs
        Sheets(1).Name = "Consolidate"
        
        ' copy headings
        Sheets(2).Activate
        Range("A1").EntireRow.Select
        Selection.Copy Destination:=Sheets(1).Range("A1")
        
        'Works from cell A2 down column A from the 'List' tab.  Change to suit if necessary.
        lngLastRow = Sheets("List").Cells(Rows.Count, "A").End(xlUp).Row
        For Each rngMyCell In Sheets("List").Range("A2:A" & lngLastRow)
            For Each w In ActiveWorkbook.Sheets
                If w.Name <> "Consolidate" Then
                    If w.Name = CStr(rngMyCell) Then
                        Application.Goto Sheets(w.Name).[a1]
                        Selection.CurrentRegion.Select
                        ' Don't copy the headings
                        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
                        Selection.Copy Destination:=Sheets("Consolidate"). _
                        Cells(Rows.Count, 1).End(xlUp)(2)
                    End If
                End If
            Next w
        Next rngMyCell
    On Error GoTo 0
    
End Sub

EDIT: Added Code tags - Moderator

 

[ea123]

Bump...