Copy lots of spreadsheets to one spreadsheet?

[tangcla]

I was wondering whether it's possible to write a macro or script to open all files in a folder, and copy the contents of each of those files to paste in another worksheet.

[royUK]

This code will prompt for a folder then combine the workbooks in that folder

Option Explicit


' API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
                                                                                       pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                   Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
                                   As Long

Public Type BrowseInfo
    hOwner     As Long
    pIDLRoot   As Long
    pszDisplayName As String
    lpszTitle  As String
    ulFlags    As Long
    lpfn       As Long
    lParam     As Long
    iImage     As Long
End Type

Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo  As BrowseInfo
    Dim sPath  As String
    Dim r As Long, x As Long, pos As Integer

    'Root folder = Desktop
    bInfo.pIDLRoot = 0&

    'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Please select the folder containing the Excel files to copy."
    Else
        bInfo.lpszTitle = msg
    End If

    'Type of directory to return
    bInfo.ulFlags = &H1

    'Display the dialog
    x = SHBrowseForFolder(bInfo)

    'Parse the result
    sPath = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal sPath)
    If r Then
        pos = InStr(sPath, Chr$(0))
        GetDirectory = Left(sPath, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub CombineFiles()
    Dim sPath  As String
    Dim sFileName As String
    Dim rLastCl As Range
    Dim oWb    As Workbook
    Dim oWs    As Worksheet
    Dim oThisWB As String

    On Error GoTo CombineFiles_Error

    oThisWB = ThisWorkbook.Name
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
        sPath = GetDirectory
        sFileName = Dir(sPath & "\*.xls", vbNormal)
        Do Until sFileName = ""
            If sFileName <> oThisWB Then
                Set oWb = Workbooks.Open(sFileName)
                For Each oWs In oWb.Worksheets
                    Set rLastCl = oWs.Cells.SpecialCells(xlCellTypeLastCell)
                    If rLastCl.Value = "" And rLastCl.Address = Range("$A$1").Address Then
                    Else
                        oWs.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    End If
                Next oWs
                oWb.Close False
            End If
            sFileName = Dir()
        Loop

        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set oWb = Nothing
    Set rLastCl = Nothing
  
    On Error GoTo 0
    Exit Sub

CombineFiles_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") whilst combinining files from " & sPath

Set oWb = Nothing
Set rLastCl = Nothing
End Sub