Combine Multiple Workbooks into One

This macro for Microsoft Excel allows you to combine multiple workbooks and worksheets into one new workbook and worksheet. When the macro runs, it prompts you to select which excel files from your computer you would like to combine and, once you select them and press ok, this macro will pull data from pre-specified worksheets in the selected workbooks and then combine the data onto one worksheet within a new excel workbook. This works quickly and easily and does not require the hard-coding of file names into the macro.

Note: This macro goes into a Module. Also, you will need to change some cell references and worksheet references if you want the macro to work for your specific needs.

Change the number in this line of code With mybook.Worksheets(1) to choose which worksheet you want data to be copied from in the workbook. 1 means the first sheet and 2 the second sheet etc.

Change the cell references in this line of code Set sourceRange = .Range("A1:A25") to the cells you want to be copied from the old worksheet onto the new worksheet.

Change the column reference in this line of code Set destrange = BaseWks.Range("A" & rnum) which is now "A" to whatever column you would like the cells to be imported.

Change this line of code to point to a specific directory where you want the macro to point by default ChDirNet "C:\".

Where to install the macro:  Module

Excel Macro to Combine Multiple Workbooks into One

Private Declare Function SetCurrentDirectoryA Lib _
     "kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
     SetCurrentDirectoryA szPath
End Sub

Sub Combine_Workbooks_Select_Files()
     Dim MyPath As String
     Dim SourceRcount As Long, Fnum As Long
     Dim mybook As Workbook, BaseWks As Worksheet
     Dim sourceRange As Range, destrange As Range
     Dim rnum As Long, CalcMode As Long
     Dim SaveDriveDir As String
     Dim FName As Variant
    With Application
         CalcMode = .Calculation
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
         .EnableEvents = False
     End With
    SaveDriveDir = CurDir
     ChDirNet "C:\"
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                         MultiSelect:=True)
     If IsArray(FName) Then
         Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
         rnum = 1
         For Fnum = LBound(FName) To UBound(FName)
             Set mybook = Nothing
             On Error Resume Next
             Set mybook = Workbooks.Open(FName(Fnum))
             On Error GoTo 0
             If Not mybook Is Nothing Then
                 On Error Resume Next
                 With mybook.Worksheets(1)
                     Set sourceRange = .Range("A1:A25")
                 End With
                 If Err.Number > 0 Then
                     Err.Clear
                     Set sourceRange = Nothing
                 Else
         If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                         Set sourceRange = Nothing
                     End If
                 End If
                 On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                         MsgBox "Not enough rows in the sheet. "
                         BaseWks.Columns.AutoFit
                         mybook.Close savechanges:=False
                         GoTo ExitTheSub
                     Else
                         Set destrange = BaseWks.Range("A" & rnum)
                         With sourceRange
                             Set destrange = destrange. _
                                             Resize(.Rows.Count, .Columns.Count)
                         End With
                         destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                     End If
                 End If
                 mybook.Close savechanges:=False
             End If
         Next Fnum
         BaseWks.Columns.AutoFit
     End If
 ExitTheSub: 
     With Application
         .ScreenUpdating = True
         .EnableEvents = True
         .Calculation = CalcMode
     End With
     ChDirNet SaveDriveDir
 End Sub

---