Option Explicit 
 
 '32-bit 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 path 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 of 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
    path = Space$(512) 
    r = SHGetPathFromIDList(ByVal x, ByVal path) 
    If r Then 
        pos = InStr(path, Chr$(0)) 
        GetDirectory = Left(path, pos - 1) 
    Else 
        GetDirectory = "" 
    End If 
End Function 
 
Sub CombineFiles() 
    Dim path            As String 
    Dim FileName        As String 
    Dim LastCell        As Range 
    Dim Wkb             As Workbook 
    Dim WS              As Worksheet 
    Dim ThisWB          As String 
     
    ThisWB = ThisWorkbook.Name 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
    path = GetDirectory 
    FileName = Dir(path & "\*.xls", vbNormal) 
    Do Until FileName = "" 
        If FileName <> ThisWB Then 
            Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName) 
            For Each WS In Wkb.Worksheets 
                Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell) 
                If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then 
                Else 
                    WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 
                End If 
            Next WS 
            Wkb.Close False 
        End If 
        FileName = Dir() 
    Loop 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
     
    Set Wkb = Nothing 
    Set LastCell = Nothing 
End Sub