VBA to merge/append all data from multiple files in the same folder

[mikeguy]

Hello - Is there a simple way to append all data from all files (located in one folder) into a single file. In this case, the only column (in all files) that contains data is Column A.

Am hoping there is VBA code I can run to get this result. Thanks for any help!

Btw, if it helps, the folder location that is holding all of the 500 plus files on my desktop (Excel 2010) is: C:\Users\Fred\SkyDrive\Sky Ebay\Excel and Office and Windows\BulkAppend

 

[maabadi]

Welcome to MrExcel Message Board.
You want all files in one worksheet or one worksheet per each file

 

[mikeguy]

Welcome to MrExcel Message Board.
You want all files in one worksheet or one worksheet per each file

All files in same worksheet. Thanks!

 

[mikeguy]

Btw, I tried running the below code (found in a google search), but I am getting a Bad file name error. I am guessing I am not specifying the folder locations correctly.

Sub ConslidateWorkbooks()
'Created by Sumit Bansal from Online Excel Tips & Tutorials
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "C:\Users\Fred\SkyDrive\Sky Ebay\Excel and Office and Windows\BulkAppend"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

 

[maabadi]

Try this. Extract each worksheet from each file to separate sheet. Change Saveas to your destination path & filename:

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
   
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200"))
If R > 0 Then
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[mikeguy]

THank

Try this. Extract each worksheet from each file to separate sheet. Change Saveas to your destination path & filename:

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200"))
If R > 0 Then
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Thanks sending that. It pulled everything together, but now it is all in separate worksheets in a single file. I probably was confusing in how I worded it. The goal is for it all to be appended into a single sheet. Is that an easy fix?

 

[maabadi]

Yes. It one column. Or each one after previous at same column.

 

[maabadi]

This code Paste all Data at Column A at Sheet1 :

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
Set xTWB = ThisWorkbook
Set Sh1 = xTWB.Sheets("Sheet1")
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row
R = Application.WorksheetFunction.CountA(xWS.Range("A1:A" & Lr1))
If R > 0 Then
Lr2 = Sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
xWS.Range("A1:A" & Lr1).Copy Sh1.Range("A" & Lr2)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[maabadi]

This one Paste Column A at each sheet at separate column:

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
Set xTWB = ThisWorkbook
Set Sh1 = xTWB.Sheets("Sheet1")
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row
R = Application.WorksheetFunction.CountA(xWS.Range("A1:A" & Lr1))
If R > 0 Then
LC = Sh1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
xWS.Range("A1:A" & Lr1).Copy Sh1.Cells(1, LC)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[rjmdc]

why couldnt this be done with power query?