Combine Excel Workbooks into 1

[Abraxus]

I have a directory with lots of .xls files. Each file contains 1-many sheets, each named uniquely.

I am trying to combine them all into 1 big workbook via VBA called from MS Access.

I found the following code but it appears to want to be called from Excel, not Access.

Code: Select all

Sub GetSheets()
Path = "C:\Users\dt\Desktop\dt kte\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Any pointers on how to change it work from Access?

[HansV]

Try this:

Code: Select all

Sub GetSheets()
    Const strPath = "C:\Users\dt\Desktop\dt kte\"
    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlTrg As Object
    Dim strFileName As String
    Dim blnStart As Boolean
    On Error Resume Next
    Set xlApp = GetObject(Class:="Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject(Class:="Excel.Application")
        If xlApp Is Nothing Then
            MsgBox "Can't start Excel!", vbCritical
            Exit Sub
        End If
        blnStart = True
    End If
    On Error GoTo ErrHandler
    Set xlTrg = xlApp.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
    strFileName = Dir(strPath & "*.xls")
    Do While strFileName <> ""
        Set xlWbk = xlApp.Workbooks.Open(FileName:=strPath & strFileName, ReadOnly:=True)
        xlWbk.Sheets.Copy After:=xlTrg.Sheets(xlTrg.Sheets.Count)
        xlWbk.Close SaveChanges:=False
        strFileName = Dir
    Loop
    xlApp.Dialogs(5).Show ' xlDialogSaveAs
ExitHandler:
    On Error Resume Next
    If blnStart Then
        xlApp.Quit
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[Abraxus]

Thank you!!