Import multiple text/csv files into single excel worksheet - vba

Question

I found this code to get the data from multiple csv/text files into an excel workbook. However, I would like the data to be appended to a single worksheet rather than each csv/text file having its own worksheet.
I have tried using Connection to get the data but when the file is being emailed to another user, there is an error prompt (Excel cannot find the text file to refresh this external data range) when he/she clicks on "Enable Content".
Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = "|"
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="CSV Files (*.csv), *.csv", _
MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
End With
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

Answer 1

Consider using QueryTables that connect to your text files and wrap in a loop of your multiple selected csv files from the array, filesToOpen:
Sub ImportCSVFiles()
Dim filesToOpen As Variant, file As Variant, LastRow As Long, fso As Object
filesToOpen = Application.GetOpenFilename _
(FileFilter:="CSV Files (*.csv), *.csv", _
MultiSelect:=True, Title:="Text Files to Open")
For Each file In filesToOpen
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set fso = CreateObject("Scripting.FileSystemObject")
fileName = fso.GetFilename(i)
If file = "False" Then Exit Sub
'IMPORT DATA FROM CSV FILES
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & file, _
Destination:=Cells(LastRow + 2, 1))
.TextFileStartRow = 30
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
Next file
' REMOVING SOURCE CONNECTIONS
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt
End Sub

Answer 2

I used this one to get the files. The downside is it gets to pull all data into this workbook.
Sub getallbooks()
Dim firstRowHeaders As Boolean
Dim fso As Object
Dim dir As Object
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim file As String
Dim fpath As String
On Error GoTo ErrMsg
Application.ScreenUpdating = False
firstRowHeaders = True 'Change from True to False if there are no headers in the first row
Set fso = CreateObject("Scripting.FileSystemObject")
'PLEASE NOTE: Change <<Full path to your Excel files folder>> to the path to the folder containing your Excel files to merge
fpath = Application.InputBox("Enter the file folder")
Set dir = fso.Getfolder(fpath)
Set thisSheet = ThisWorkbook.ActiveSheet
For Each filename In dir.Files
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next filename
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
For Each filename In dir.Files
file = Right(filename, Len(filename) - InStrRev(filename, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next filename
#End If
Application.ScreenUpdating = True
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Here is another way which creates a new workbook to store the data:
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
Dim LastRow As Long, LastCol As Long
' Change this to the path\folder location of your files.
MyPath = InputBox("Enter the address here")
' 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 & "*.csv*") 'You can change the file type to suit your need here
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)
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'choose which column has data all the way down the last row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Set sourceRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
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, if you want; Here I choose not.
' With sourceRange
' BaseWks.Cells(rnum, "A"). _
' Resize(.Rows.Count).Value = MyFiles(FNum)
' End With
' Set the destination range.
Set destrange = BaseWks.Range("A" & 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
Both of them get the header from each files. So You may want to remove them with only the top one left alone.

Answer 3

Thanks for the replies. Instead of using the code that i have shared above, I re-used connection which was my original code. To counter the connection error prompt (Excel cannot find the text file to refresh this external data range) when he/she clicks on "Enable Content", I added a code which removes all connections after the data is imported into the excel file. Hope this is helpful to someone who encountered the same issue as me. :)
Sub ImportMultipleCSV()
Dim myfiles
Dim i As Integer
myfiles = Application.GetOpenFilename(filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
If IsArray(myfiles) Then
For i = LBound(myfiles) To UBound(myfiles)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1, 0))
.Name = "Sample"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Else
MsgBox "No File Selected"
End If
Dim xConnect As Object
For Each xConnect In ActiveWorkbook.Connections
If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete
Next xConnect
End Sub