ExcelBanter - View Single Post - VBA-copy all worksheets except three specific ones

Royzer

Hi. I have a wb with 20 sheets. I need to copy the data ranges from the first 17, but not the last 3, "Create File", "Pull" and "Save as DIF". The data will be pasted on a new sheet named "Target" created by the code. The code below does everything I want it to EXCEPT it also copies and pastes the three sheets above. How can I modify the code to exclude these three sheets?

Thank you.

Code:

Sub CombineSheets()

    'This macro will copy data from worksheets and past to "Target" sheet

    Dim i As Integer
    Dim j As Long
    Dim SheetCnt As Integer
    Dim lstRow1 As Long
    Dim lstRow2 As Long
    Dim lstCol As Integer
    Dim ws1 As Worksheet

    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    On Error Resume Next

    'Delete the Target Sheet on the document (in case it exists)
    Sheets("Target").Delete
    'Count the number of sheets on the Workbook
    SheetCnt = Worksheets.Count

    'Add the Target Sheet
    Sheets.Add after:=Worksheets(SheetCnt)
    ActiveSheet.Name = "Target"
    Set ws1 = Sheets("Target")
    lstRow2 = 1
    'Define the row where to start copying
    
    j = 7

    'Combine the sheets
    
    For Each ws1 In Worksheets
        If ws1.Name < "Pull" Then
    For i = 1 To SheetCnt
        Worksheets(i).Select

        'check what is the last column with data
        lstCol = ActiveSheet.Cells(5, ActiveSheet.Columns.Count).End(xlToLeft).Column

        'check what is the last row with data
        lstRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

        'Define the range to copy
        Range("A" & 7, Cells(lstRow1, lstCol)).Select

        'Copy the data
        Selection.Copy
        ws1.Range("A" & lstRow2).PasteSpecial
        Application.CutCopyMode = False

        'Define the new last row on the Target sheet
        lstRow2 = ws1.Cells(65536, "A").End(xlUp).Row + 1

        'Define the row where to start copying
        
        j = 2
    Next

    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Sheets("Target").Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    

End Sub