copy and stack all tabs data to one sheet in another workbook using vba

[NateD1]

Hi All,
i have the below code i found which copys all data in multiple tabs in a workbook to one sheet.
would some one be able to adjust this code or simplifying so that it only copies particular tabs instead of all tabs. (i.e only Sheet1,Sheet3,Sheet4,Sheet5)
i need all this data then exported into another work book.

example of what ideally id like it to do, Main workbook where data to be copied to: workbook1, data where is stored and macro combines sheets: Workbook2
workbook 1, run macro > opens workbook 2 > combines all data on named tabs > exports combined stacked data to "Sheet1" on workbook1 > close Workbook2

Sub Combine()
    Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"

    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Combined" Then
            Application.GoTo Sheets(s.Name).[a1]
            Selection.CurrentRegion.Select
            ' Don't copy the headings
            Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
            Selection.Copy Destination:=Sheets("Combined"). _
              Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

thanks

 

[mohadin]

Hi

Sub Combine()
    Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add    ' add a sheet in first place
    Sheets(1).Name = "Combined"

    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    Reqsheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
    For i = 1 To UBound(Reqsheets)
        Application.GoTo Sheets(i).[a1]
        Selection.CurrentRegion.Select
        ' Don't copy the headings
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets("Combined"). _
                                    Cells(Rows.Count, 1).End(xlUp)(2)
    End If
Next
End Sub

 

[NateD1]

Hi

Sub Combine()
    Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add    ' add a sheet in first place
    Sheets(1).Name = "Combined"

    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    Reqsheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
    For i = 1 To UBound(Reqsheets)
        Application.GoTo Sheets(i).[a1]
        Selection.CurrentRegion.Select
        ' Don't copy the headings
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets("Combined"). _
                                    Cells(Rows.Count, 1).End(xlUp)(2)
    End If
Next
End Sub

for some reason it doesnt work at all now...

 

[mohadin]

Then try

Reqsheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
    For Each s In Reqsheets
        Application.GoTo Sheets(s).[a1]
        Selection.CurrentRegion.Select
        ' Don't copy the headings
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets("Combined"). _
                                    Cells(Rows.Count, 1).End(xlUp)(2)
                                    ...

 

[NateD1]

Then try

Reqsheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
    For Each s In Reqsheets
        Application.GoTo Sheets(s).[a1]
        Selection.CurrentRegion.Select
        ' Don't copy the headings
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets("Combined"). _
                                    Cells(Rows.Count, 1).End(xlUp)(2)
                                    ...

not sure what i was doing wrong but couldnt get it to work, i found this one on another thread which works now by selecting Sheets numbers 3 to 7.
do you know what i can add to this code that will open another workbook via file path/filename, run this macro, and then return the "master Sheet" data?

Sub Copy_Sheets_To_Master()

Application.ScreenUpdating = False

Dim i As Long
Dim Lastrow As Long
Dim ans As Long

For i = 3 To 7
With Sheets(i)
    ans = .Cells(Rows.Count, "A").End(xlUp).Row
    Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
        .Cells(2, 1).Resize(ans, 7).Copy Sheets("Master").Cells(Lastrow, 1)
End With
Next
Application.ScreenUpdating = True
End Sub

 

[NateD1]

not sure what i was doing wrong but couldnt get it to work, i found this one on another thread which works now by selecting Sheets numbers 3 to 7.
do you know what i can add to this code that will open another workbook via file path/filename, run this macro, and then return the "master Sheet" data?

Sub Copy_Sheets_To_Master()

Application.ScreenUpdating = False

Dim i As Long
Dim Lastrow As Long
Dim ans As Long

For i = 3 To 7
With Sheets(i)
    ans = .Cells(Rows.Count, "A").End(xlUp).Row
    Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
        .Cells(2, 1).Resize(ans, 7).Copy Sheets("Master").Cells(Lastrow, 1)
End With
Next
Application.ScreenUpdating = True
End Sub

if anyone knows how to add this to this code that would be a great help for me, as having to copy and paste it manually from another work book each time after running the above.
example: workbook1 (current open) > run macro > opens closed workbook2 via file path (the name of the file is the same, except date at end changes daily( WB2 19.11.2020) > runs above code in WB2 to combine sheets > paste data to WB1 sheet1.

 

[mumps]

Try:

Sub Copy_Sheets_To_Master()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a folder and file."
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    For Each ws In Sheets(Array("Sheet1", "Sheet3", "Sheet4", "Sheet5"))
        With ws
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Cells(2, 1).Resize(lRow - 1, 7).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[NateD1]

Try:

Sub Copy_Sheets_To_Master()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title =[B] "Z:\Filelocation\filename.xlsb"[/B]
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    For Each ws In Sheets(Array("Sheet1", "Sheet3", "Sheet4", "Sheet5"))
        With ws
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Cells(2, 1).Resize(lRow - 1, 7).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub

thank you for repling, when i run it i cant get past this part of the code FileName = flder.SelectedItems(1), i have added in the file location as above.

 

[mumps]

Try:

Sub Copy_Sheets_To_Master()
    Application.ScreenUpdating = False
    Dim wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Set wkbSource = Workbooks.Open("Z:\Filelocation\filename.xlsb")
    For Each ws In Sheets(Array("Sheet1", "Sheet3", "Sheet4", "Sheet5"))
        With ws
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Cells(2, 1).Resize(lRow - 1, 7).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next ws
    wkbSource.Close False
    Application.ScreenUpdating = True
End Sub

 

[NateD1]

Try:

Sub Copy_Sheets_To_Master()
    Application.ScreenUpdating = False
    Dim wkbSource As Workbook, wsDest As Worksheet, ws As Worksheet, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Set wkbSource = Workbooks.Open("Z:\Filelocation\filename.xlsb")
    For Each ws In Sheets(Array("Sheet1", "Sheet3", "Sheet4", "Sheet5"))
        With ws
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Cells(2, 1).Resize(lRow - 1, 7).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next ws
    wkbSource.Close False
    Application.ScreenUpdating = True
End Sub

Amazing it works perfectly thank you so much!!, one last thing sorry.. on the end of the file name it has a date that changes. can i = the file name to a cell? so i can change the date each day ?