UPDATE - Excel Macro to Combine Multiple Spreadsheets Into One
The Tip of the Night for October 13, 2016 showed how to use a macro to combine multiple Excel workbooks. At the request of a visitor to this site, I have edited the VBA code so that it will collect all of the populated cells on each worksheet (assuming the data begins at A1 and there are no gaps.) The previous version of the code required that the user estimate the maximum range of data on the source Excel files. On the line which begins:
Set sourceRange =
. . . we could enter A1:K25, if we were certain that none of the Excel files to be merged had more than 25 rows or more than 11 columns. This would necessitate opening and reviewing each source file or making a pretty good guess. If would also leave the new spreadsheet created with the macro with lots of extra blank rows that would take additional steps to eliminate.
In this version of the macro the line setting the range has been updated to:
Set sourceRange = .Range("a1", Range("a1").End(xlDown).End(xlToRight))
Which goes from cell A1 to the end of the entered text. Now the resulting spreadsheet with all of the data from the source files won't have unnecessary blank rows.
[the text editor for my Wix site may alter the formatting of the VBA Code. If it doesn't work go to the my source for the code here and enter in my edit on your own.]
Sub MergeAllWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() 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
' Change this to the path\folder location of your files. MyPath = "C:\excel combo 2"
' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If
' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If
' Fill the myFiles array with the list of Excel files ' in the search folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop
' Set various application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With
' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1
' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0
If Not mybook Is Nothing Then On Error Resume Next
' Change this range to fit your own needs. With mybook.Worksheets(1) Set sourceRange = .Range("a1", Range("a1").End(xlDown).End(xlToRight)) End With
If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If source range uses all columns then ' skip this file. 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 "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else
' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With
' Set the destination range. Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range ' to the destination range. 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: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub