How to loop through excel sheets in same directory and copy all sheets into a single workbook?

[XcelNoobster]

How would I create a macro that loops through all the excels sheets in a directory and copy all the sheets in a new workbook?

 

[mumps]

Change the folder path (in red) to suit your needs.

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, ws As Worksheet
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Mario\Forum Help\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each ws In Sheets
                ws.Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            Next ws
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[XcelNoobster]

Hello,

I went ahead and copied this macro in a new workbook(Book1), changed the path to where my folder is, ran it and I don't see the files being copied over to the Book1. Have an idea why?

[CODE=vba]
Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, ws As Worksheet
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each ws In Sheets
                ws.Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            Next ws
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

[/CODE]

 

[mumps]

Do your files have an “xlsx” extension? Post your revised macro.

 

[XcelNoobster]

Do your files have an “xlsx” extension? Post your revised macro.

Yes, they all have .xlsx extension.

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, ws As Worksheet
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each ws In Sheets
                ws.Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            Next ws
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Path should be: “C:\Test\”

 

[XcelNoobster]

Path should be: “C:\Test\”

Thanks! That solved it

 

[mumps]

You are very welcome.