Import multiple text files into single worksheet - vba

I found the following code which imports each text file into a separate worksheet and it worked perfectly. Is there a way to modify the code so ALL text files are imported into a SINGLE worksheet?
I'm using Excel 2013 on Windows7 64 bit if that makes a difference.
Sub ImportTXTFiles()
Dim fso As Object
Dim xlsheet As Worksheet
Dim qt As QueryTable
Dim txtfilesToOpen As Variant, txtfile As Variant
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
txtfilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
For Each txtfile In txtfilesToOpen
' FINDS EXISTING WORKSHEET
For Each xlsheet In ThisWorkbook.Worksheets
If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
xlsheet.Activate
GoTo ImportData
End If
Next xlsheet
' CREATES NEW WORKSHEET IF NOT FOUND
Set xlsheet = ThisWorkbook.Worksheets.Add( _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "")
xlsheet.Activate
GoTo ImportData
ImportData:
' DELETE EXISTING DATA
ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft
' IMPORT DATA FROM TEXT FILE
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
Destination:=ActiveSheet.Cells(1, 1))
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.Refresh BackgroundQuery:=False
End With
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt
Next txtfile
Application.ScreenUpdating = True
MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
Set fso = Nothing
End Sub

A lot of the code in here is dealing with creating new tabs etc. so that can go.
What you're left with is a loop that loads each text file into Cells(1,1) - so if we tweak that to point at a value which checks the last used cell in column A, then this should do what you need:
Sub ImportTXTFiles()
Dim fso As Object
Dim xlsheet As Worksheet
Dim qt As QueryTable
Dim txtfilesToOpen As Variant, txtfile As Variant
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
txtfilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
With ActiveSheet
For Each txtfile In txtfilesToOpen
importrow = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' IMPORT DATA FROM TEXT FILE
With .QueryTables.Add(Connection:="TEXT;" & txtfile, _
Destination:=.Cells(importrow, 1))
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.Refresh BackgroundQuery:=False
End With
Next txtfile
For Each qt In .QueryTables
qt.Delete
Next qt
End With
Application.ScreenUpdating = True
MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
Set fso = Nothing
End Sub
Also, I notice you delete 'all' the query tables inside your loop. This isn't necessary. Just delete them all once they're all loaded.

I believe the following will do what you expect, this will bring all your text data into a single worksheet, it will check for the last row with data in Column A, and offset by one row to import data from the next Text File:
Sub ImportTXTFiles()
Dim fso As Object
Dim xlsheet As Worksheet
Dim qt As QueryTable
Dim LastRow As Long
Dim txtfilesToOpen As Variant, txtfile As Variant
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
txtfilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
For Each txtfile In txtfilesToOpen
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
' IMPORT DATA FROM TEXT FILE
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
Destination:=ActiveSheet.Cells(LastRow, 1))
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.Refresh BackgroundQuery:=False
End With
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt
Next txtfile
Application.ScreenUpdating = True
MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
Set fso = Nothing
End Sub

Related

DoCmd.TransferSpreadsheet acImport error "External table is not in the expected format"

Hi I am getting this error
"External table is not in the expected format"
...when i try to transfer excel data to a access Table. I have data in text file that has a description field. In order to avoid truncation at 250 character limit, I convert the text file to EXCEL and then transfer excel to access database. But I get this error.... I have both excel 2010 and 2016 on my machine installed. thanks all in advance.
Sub ImportPPDE_v2()
Dim fDialog As Office.FileDialog
Dim strNewPath As String
On Error GoTo GameOver
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Set up the fDialog variable
'Set the Title, add a filter for text files, and set the initial filepath we want to look at, we are defaulting to the Clarity Extract folder
fDialog.Filters.Clear
fDialog.Title = "Select Latest Project Portfolio Data Extract File"
fDialog.Filters.Add "*.txt", "*.txt"
fDialog.InitialFileName = "G:\Clarity EPPM Extracts\"
fDialog.AllowMultiSelect = False
fDialog.Show
'turn off warnings, we don't need to see this
DoCmd.SetWarnings False
'Check to make sure a file has been selected, and if so that the Project Portfolio Data Extract file has been selected
If fDialog.SelectedItems.Count = 0 Then
MsgBox "No File has been selected. Load actions have been cancelled.", , "No File Selected"
GoTo GameOver
ElseIf InStr(1, fDialog.SelectedItems(1), "Project Portfolio Data extract_") = 0 Then
MsgBox "The file selected appears to be incorrect. It should be the Data Extract file. Load actions have been cancelled.", , "ERROR OCCURRED IN DATA LOAD"
GoTo GameOver
End If
'First delete everything currently in the table
DoCmd.RunSQL "Delete * from tbl_Project_Portfolio_Data_Load"
'DoCmd.TransferText , "Spec_PPDE", "tbl_Project_Portfolio_Data_Load", fDialog.SelectedItems(1)
'First isolate the file name from the selected path, then change the file extension to .xls
strNewPath = Right(fDialog.SelectedItems(1), Len(fDialog.SelectedItems(1)) - InStrRev(fDialog.SelectedItems(1), "\"))
strNewPath = "C:\" & Left(strNewPath, Len(strNewPath) - 4) & ".xlsx"
'Copy the Portfolio data extract file to the user's C: drive as a .xls file
Call SaveAsFile(CStr(fDialog.SelectedItems(1)), strNewPath)
'Now import the new data as selected above
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Project_Portfolio_Data_Load", strNewPath, True
'Now update the Load_Date to be today
DoCmd.RunSQL "Update tbl_Project_Portfolio_Data_Load set [Load Date] = #" & Date & "# Where [Load Date] IS NULL"
'Let the user know the process finished successfully
MsgBox "Project Portfolio Data Extract Data has been uploaded", , "Victory!"
GameOver:
'Turn our warnings back on
DoCmd.SetWarnings True
'Set this back to nothing
Set fDialog = Nothing
'Check if an error occurred that would prevent the expected data from being loaded
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
I get this erorr when my code try to transfer excel sheet into the empty table
here is save as code
Sub SaveAsFile(currpath As String, newpath As String)
Dim wb As Workbook, strWB As String
Dim NewWB As String
'The purpose of this module is to copy a file from a given filepath to a user's C: Drive.
'It is also converting the file from .txt to a .xls format
'This is originally intended to be used with the Project Portfolio Data Extract load
'Delete any existing workbook that is there now with the same name
On Error Resume Next
Kill newpath
On Error GoTo GameOver
'Open the current file
Set wb = Workbooks.Open(currpath)
'MsgBox wb.FileFormat
'Application.DisplayAlerts = False
'Save it as a .xls file
wb.SaveAs newpath, xlNormal
'Application.DisplayAlerts = True
'MsgBox wb.FileFormat
'Close the workbook
wb.Close False
GameOver:
Set wb = Nothing
End Sub
If you really cannot link to the text file without truncation (I could) and since simple Open doesn't work, do an import of the text file to Excel then SaveAs an Excel workbook. I used Excel macro recorder to generate some code and adapted to an Access procedure.
Sub TextToExcel1(currpath As String, newpath As String)
Dim xlx As Excel.Application, xlw As Excel.Workbook, xls As Excel.Worksheet
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
xlx.Visible = False
Set xlw = xlx.Workbooks.Add
Set xls = xlw.Worksheets("Sheet1")
With xls.QueryTables.Add("TEXT;" & currPath, Range("$A$1"))
.Name = "Test"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
xlw.SaveAs newPath
Set xls = Nothing
xlw.Close False
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub
And then this version:
Sub TextToExcel2(currpath As String, newpath As String)
Dim xlx As Excel.Application
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
xlx.Visible = False
xlx.Workbooks.OpenText filename:=currPath, Origin:=437, StartRow:=1, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False,
Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1)), TrailingMinusNumbers:=True
xlx.ActiveWorkbook.SaveAs filename:=newPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub
Or even:
Sub TextToExcel3(currpath As String, newpath As String)
Dim xlx As Excel.Application
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
xlx.Workbooks.Open (currpath)
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
xlx.Visible = False
xlx.ActiveWorkbook.SaveAs filename:=newPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub
I am having issue getting version 1 to replicate consistently. Versions 2 and 3 both seem reliable.

Change existing macro to copy formulas from specific columns

This is my still my first macro, I have been searching like a mad man trying to get this to work...and it's getting close!
I have it set to copy "Pricing_Cost" sheet from Active workbook into a new workbook as values and then manipulate it beyond that. What I really need is to modify that step so that certain columns copy values, others copy formulas. I have columns A:X
Columns needing to be pasted as values = A,E,F,H,I,J,K,L,M,N,T,U,V,W,X
Columns needing to pasted as formula = B,C,D,G,O,P,Q,R,S
This is within the CopyRemoveFormSave sub
I'm guessing maybe I should copy the whole thing as formulas and then cut and paste as values the columns that need to be converted to values? Not really sure how to do that with the code I have here...
Public strFile As String
Sub RunAll()
Call load_csv
Call CopyRemoveFormAndSave
Call Splitbook
End Sub
Sub load_csv()
Dim fStr As String
With Application.FileDialog(msoFileDialogFilePicker)
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Cancel Selected"
Exit Sub
End If
'fStr is the file path and name of the file you selected.
fStr = .SelectedItems(1)
End With
Sheets("Product_Weekly").UsedRange.ClearContents
With ThisWorkbook.Sheets("Product_Weekly").QueryTables.Add(Connection:= _
"TEXT;" & fStr, Destination:=ThisWorkbook.Sheets("Product_Weekly").Range("$A$1"))
.Name = "CAPTURE"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
'~~> Function to get user's temp directoy
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
Sub CopyRemoveFormAndSave()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet
Dim wsName As String, NewName As String
' Dim shp As Shape
Set wb = ThisWorkbook
wsName = ActiveSheet.Name
NewName = wsName & ".xlsm"
wb.SaveCopyAs TempPath & NewName
Set wbNew = Workbooks.Open(TempPath & NewName)
wbNew.Sheets(wsName).UsedRange.Value = wbNew.Sheets(wsName).UsedRange.Value
Application.DisplayAlerts = False
For Each ws In wbNew.Worksheets
If ws.Name <> wsName Then ws.Delete
Next ws
Application.DisplayAlerts = True
' For Each shp In wbNew.Sheets(wsName).Shapes
' If shp.Type = 8 Then shp.Delete
' Next
'
'~~> Do a save as for the new workbook if required.
'
'End Sub
Columns("W:W").Replace "2", "KevinClark", xlWhole
Columns("W:W").Replace "9", "PaulG", xlWhole
Columns("W:W").Replace "O", "KevinClark", xlWhole
Columns("W:W").Replace "I", "KevinClark", xlWhole
Columns("W:W").Replace "4", "PaulG", xlWhole
Columns("W:W").Replace "8", "KevinClark", xlWhole
Columns("W:W").Replace "7", "KevinClark", xlWhole
'Sub SplitData()
Const NameCol = "W"
Const HeaderRow = 3
Const FirstRow = 4
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Buyer As String
Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
Buyer = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(Buyer)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = Buyer
' SrcSheet.Range(HeaderRow).Copy Destination:=TrgSheet.Range(HeaderRow)
SrcSheet.Range("A1:W3").Copy Destination:=TrgSheet.Range("A1:W3")
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Application.ScreenUpdating = True
Dim sht As Worksheet
''AutoFit One Column
' ThisWorkbook.Worksheets("Sheet1").Columns("O:O").EntireColumn.AutoFit
'
''AutoFit Multiple Columns
' ThisWorkbook.Worksheets("Sheet1").Range("I:I,L:L").EntireColumn.AutoFit 'Columns I & L
' ThisWorkbook.Worksheets("Sheet1").Range("I:L").EntireColumn.AutoFit 'Columns I to L
'
''AutoFit All Columns on Worksheet
' ThisWorkbook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit
'AutoFit Every Worksheet Column in a Workbook
For Each sht In wbNew.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht
End Sub
Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = "C:\Users\Jimbo.JAMESP-ACERLT\Documents\For Gary\Output"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Sheets
If xWs.Name <> "Pricing Cost" Then
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
As you say I think the best step is to copy all as formulas initially. What I would do next is define an array which contains the column letters which you need to be values, you can do that as follows.
ValArr = Array("A","E","F","H","I","J","K","L","M","N","T","U","V","W","X")
Then you can loop through this array and turn each column to values.
For x = Lbound(ValArr) To Ubound(ValArr)
'Paste values in column ValArr(x)
Next
I hope this helps, let me know if you need any more clarification.
You can do it without any copy and pasting. For example let's say you want to copy all the formulas from Sheet1 to Sheet2 you can do something like this:
for i = 1 to lastRow
for j in 1 to lastCol
Sheets("Sheet2").cells(i,j).formula = Sheets("Sheet1").cells(i,j).formula
next j
next i
Also if there's no formula it just copies the text so you can do that for all the cells.

Import multiple text/csv files into single excel worksheet

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
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
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.
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

Issue with loading multiple comma delaminated text in excel using VBA

Good morning,
I am trying to load multiple comma delaminated casv style file with .plt extension in excel with.
What I am trying to do is to load openfolder dialogue and select the folder where my codes are saved wit the first bit of code and paste the path in TextBox1. I have managed to successfully do that.
Then I am trying to run further codes with the run button to load all files in a new workbook with filenames as sheet name. But I am struggling with the following 2 things:
When I try to open the file in new workbook, each file opening in new workbook but I want them to just open 1 new workbook with each files in different worksheets.
The program works fine when I manually assign directory path but when I ask the program to read the folder path where the files are saved from the textbox its failing
Could someone please give me some advise on how to rectify this, many thanks. My codes are as follows:
I have added comments on possibly where I think I am doing something wrong as by replacing the commented sections manually with the file path sich as "C:\Users\Desktop\test\" the program works fine to load in same workbook all files.
'Code for the button on the right of textbox 1
Private Sub FilePath_Button_Click()
get_folder
End Sub
' code for the run button
Private Sub Run_Button_Click()
load_file
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub UserForm_Click()
End Sub
'code for the fild open dialouge box to locate folder where the files are saved
Public Sub get_folder()
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
TextBox1.Text = FolderName
End Sub
'codes for the run button to import the files
Sub load_file()
Dim strFile As String
Dim ws As Worksheet
strFile = Dir("TextBox1.Text*.plt") ' I think this is the bit where I doing something wrong
Do While strFile <> vbNullString
Set ws = Sheets.Add
With ws.QueryTables.Add(Connection:= _
"TEXT;" & "TextBox1.Text" & strFile, Destination:=Range("$A$1")) ' and also "TextBox1.Text" I think not right as if i replace this two section that I commented with the file path manually the program works fine
.Name = strFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End Sub
Try replacing:
strFile = Dir("TextBox1.Text*.csv") ' I think this is the bit where I doing something wrong
Do While strFile <> vbNullString
Set ws = Sheets.Add
with
StrFile = Dir(Me.TextBox1.Text & "\*.csv")
Do While Len(StrFile) > 0
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = StrFile
EDIT
To add the .csv files to new workbooks
Dim wb as workbook
Do While Len(StrFile) > 0
Set wb = Workbooks.Add
'added workbook becomes the activeworkbook
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = StrFile
Is there any reason you are using a QueryTable? Just opening the workbook and copying the sheet should suffice as the CSV file will already have the sheetname as the filename.
Try replacing the load_file() procedure with this:
Sub load_file()
Dim wb1 As Workbook, wb2 As Workbook
Dim filePath As String, strFile As String
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
filePath = TextBox1.Text
strFile = Dir(filePath)
While Not strFile = ""
If LCase(Right(strFile, 4)) = ".plt" Then
Set wb2 = Workbooks.OpenText(Filepath:=fileName & "\" & strFile, Datatype:=xlDelimited, Comma:=True) '// open the workbook
wb2.Sheets(1).Copy after:=wb1.Sheets(wb1.Sheets.Count) '// copy the page to wb1
wb2.Close False '// close wb2
Set wb2 = Nothing '// release from memory
End If
strFile = Dir()
Wend
Set wb1 = Nothing
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

How to import a zipped csv hosted online into Excel

I have a simple link www.example.com/file.zip
Inside there is a csv file
There are no login forms required to download the file, it's a direct link.
Is there any way to download the file to a temp folder, extract it, and import as a new sheet into the existing sheet? (All via one button VBA)
Try the following code. It uses the zip functionality that is built in windows and to load correctly the CSV file is necessary to rename the file to TXT.
'Main Procedure
Sub DownloadAndLoad()
Dim url As String
Dim targetFolder As String, targetFileZip As String, targetFileCSV As String, targetFileTXT As String
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
Dim newSheet As Worksheet
url = "http://www.example.com/data.zip"
targetFolder = Environ("TEMP") & "\" & RandomString(6) & "\"
MkDir targetFolder
targetFileZip = targetFolder & "data.zip"
targetFileCSV = targetFolder & "data.csv"
targetFileTXT = targetFolder & "data.txt"
'1 download file
DownloadFile url, targetFileZip
'2 extract contents
Call UnZip(targetFileZip, targetFolder)
'3 rename file
Name targetFileCSV As targetFileTXT
'4 Load data
Call LoadFile(targetFileTXT)
End Sub
Private Sub DownloadFile(myURL As String, target As String)
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.send
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile targetFile, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Private Function RandomString(cb As Integer) As String
Randomize
Dim rgch As String
rgch = "abcdefghijklmnopqrstuvwxyz"
rgch = rgch & UCase(rgch) & "0123456789"
Dim i As Long
For i = 1 To cb
RandomString = RandomString & Mid$(rgch, Int(Rnd() * Len(rgch) + 1), 1)
Next
End Function
Private Function UnZip(PathToUnzipFileTo As Variant, FileNameToUnzip As Variant)
' Unzips a file
' Note that the default OverWriteExisting is true unless otherwise specified as False.
Dim objOApp As Object
Dim varFileNameFolder As Variant
varFileNameFolder = PathToUnzipFileTo
Set objOApp = CreateObject("Shell.Application")
' the "24" argument below will supress any dialogs if the file already exist. The file will
' be replaced. See http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx
objOApp.Namespace(FileNameToUnzip).CopyHere objOApp.Namespace(varFileNameFolder).items, 24
End Function
Private Sub LoadFile(file As String)
Set wkbTemp = Workbooks.Open(Filename:=file, Format:=xlCSV, Delimiter:=";", ReadOnly:=True)
wkbTemp.Sheets(1).Cells.Copy
'here you just want to create a new sheet and paste it to that sheet
Set newSheet = ThisWorkbook.Sheets.Add
With newSheet
.Name = wkbTemp.Name
.PasteSpecial
End With
Application.CutCopyMode = False
wkbTemp.Close
End Sub
You can find it in simple codes there:
Download a File with VBA
Unzip Files
And use this Sub to import the file data to a new sheet.
Sub InsertCSVData()
Sheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Ttemp\filename.csv", Destination:=Range("$B$7"))
.Name = "filename"
.FieldNames = True
.RowNumbers = False
.PreserveFormatting = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
' Don't forget to choose your delimiters and text type.
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Hope that helps.