Formatting data imported from csv files to excel spreadsheet - vba

I'm working on writing a script that will import the csv file outputs from a scanning electron microscope to a master spreadsheet organized by date and sample number. Having never used vba before and with little programming experience before now, this has been quite a challenge. There are a few thousand files organized by sample and image number. Right now what I have is able to read in the csv files and copy them to a single spreadsheet. The csv files look something like this
Atomic number,Element symbol,Element name,Concentration percentage,Certainty
8,O,Oxygen,57.5,0.99
14,Si,Silicon,15.5,0.99
26,Fe,Iron,13.6,0.97
13,Al,Aluminium,8.4,0.98
19,K,Potassium,3.3,0.97
22,Ti,Titanium,0.9,0.89
65,Tb,Terbium,0.7,0.53
When I run the code I have, the above data is copied from each file and pasted into the master spreadsheet. What I would like to do is have it format this data. Here is what I have so far to actually write the data to a spreadsheet.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername
BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
'FileExtStr = ".xls": FileFormatNum = 56
End If
XLSFileName = DefPath & "SEM Master File" & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "\" Then
foldername = foldername & "\"
End If
Open BatFileName For Output As #1
Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
& Chr(34) & " " & TXTFileName
Close #1
ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False, AdjustColumnWidth = True
Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
Wb.Close savechanges:=False
MsgBox "You will find the Excel file here: " & vbNewLine & XLSFileName
Kill BatFileName
Kill TXTFileName
Application.ScreenUpdating = True
End If
End Sub
The name of each file is its sample/image number and date. What I need is for this to ignore the first row of data in each csv file (Atomic number,Element symbol, etc.), create a single protected row at the top of the sheet that has those labels, and record the name of each file in a column next to each row of data from that file. With this information recorded I think I will be able to organize the data the way I want.

check out this approach using ADO. Adapted from: https://msdn.microsoft.com/en-us/library/ms974559.aspx
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
strPathtoTextFile = "C:\Databases\"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited"""
objRecordset.Open "SELECT * FROM MyCSV.csv where [Atomic number] <> "Atomic number"", _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
Range("A2").CopyFromRecordset objRecordset
objRecordset.close
objConnection.close

Related

Why does my Access database object variable lose connection to its source file midway through reading its Modules container?

We use a VBA tool to extract modules, forms and reports from our Access applications and create an executable for users. This tool has been working without any problems until very recently. However, when I use it to extract from a couple of applications, I keep on encountering an "Automation Error (The remote procedure call failed)" error. However, my colleague (running the same code on a virtually identical build) is able to run it ok.
This is running on Win10 Pro (v2004 - 19041.685), Office 2016 Pro Plus (16.0.4266.1001). I believe my colleague's machine should be the same, as we have only just moved across to these laptops.
This is the core code:
Public Sub ExportAll()
On Error GoTo ErrorProc
Dim oAccessApp As Access.Application
Dim oDoc As Document
Dim sFilePath As String
Dim oDb As Database
Dim fso As FileSystemObject
Dim strFile As String
Dim strFolder As String
strFile = "accdb path"
strFolder = oApp.GetFolder(strFile)
Set oAccessApp = oApp.OpenDatabase(strFile)
Set oDb = oAccessApp.CurrentDb
Set fso = New FileSystemObject
If Not fso.FolderExists((strFolder) & "\SCC") Then
fso.CreateFolder strFolder & "\SCC"
End If
If Not fso.FolderExists(strFolder & "\SCC\Modules") Then
fso.CreateFolder strFolder & "\SCC\Modules"
End If
If Not fso.FolderExists(strFolder & "\SCC\Forms") Then
fso.CreateFolder strFolder & "\SCC\Forms"
End If
If Not fso.FolderExists(strFolder & "\SCC\Reports") Then
fso.CreateFolder strFolder & "\SCC\Reports"
End If
For Each oDoc In oDb.Containers("Modules").Documents
DoEvents
sFilePath = strFolder & "\SCC\Modules\" & oDoc.Name & ".bas.txt"
oAccessApp.SaveAsText acModule, oDoc.Name, sFilePath
Next
For Each oDoc In oDb.Containers("Forms").Documents
DoEvents
sFilePath = strFolder & "\SCC\Forms\" & oDoc.Name & ".frm.txt"
oAccessApp.SaveAsText acForm, oDoc.Name, sFilePath
Next
For Each oDoc In oDb.Containers("Reports").Documents
DoEvents
sFilePath = strFolder & "\SCC\Reports\" & oDoc.Name & ".rpt.txt"
oAccessApp.SaveAsText acReport, oDoc.Name, sFilePath
Next
oDb.Close
Set oDb = Nothing
oAccessApp.Quit
Set oAccessApp = Nothing
Exit Sub
ErrorProc:
If Not (oAccessApp Is Nothing) Then
oAccessApp.Quit
End If
Set oAccessApp = Nothing
MsgBox Err.Description, vbExclamation, "Error " & Err.Number
End Sub
As the extraction takes place, the database being extracted should remain open throughout. Each failure occurs in the For Each oDoc In oDb.Containers("Modules").Documents loop, and happens when a particular module is referenced by the oDoc variable. When I step through and reach the offending module, all is fine until the line with oDoc.Name is hit, at which point the database closes and all the messages for the object oDb reads "".
The module causing the problem is below:
Option Compare Database
Option Explicit
'
' Opens file using default program
' (.xls files open in Excel, .doc files open in Word, etc)
'
'Code Courtesy of
'Dev Ashish
#If Win64 Then
Private Declare PtrSafe Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
Private Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
#End If
Public Enum ShellExecuteWinStyle
WIN_NORMAL = 1 'Open Normal
WIN_MAX = 2 'Open Maximized
WIN_MIN = 3 'Open Minimized
End Enum
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
'
' Opens file using default program
' (.xls files open in Excel, .doc files open in Word, etc)
'
Function ShellExecute(strFile As Variant, lShowHow As ShellExecuteWinStyle)
#If Win64 Then
Dim lRet As LongPtr
#Else
Dim lRet As Long
#End If
Dim varTaskID As Variant
Dim stRet As String
Dim stFile As String
If IsNull(strFile) Or strFile = "" Then Exit Function
stFile = strFile
'First try ShellExecute
lRet = apiShellExecute(hWndAccessApp, vbNullString, _
stFile, vbNullString, vbNullString, lShowHow)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
'Try the OpenWith dialog
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& stFile, WIN_NORMAL)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Error: Out of Memory/Resources. Couldn't Execute!"
Case ERROR_FILE_NOT_FOUND:
stRet = "Error: File not found. Couldn't Execute!"
Case ERROR_PATH_NOT_FOUND:
stRet = "Error: Path not found. Couldn't Execute!"
Case ERROR_BAD_FORMAT:
stRet = "Error: Bad File Format. Couldn't Execute!"
Case Else:
End Select
End If
ShellExecute = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
I have tried the following:
removing the problem module (process completes successfully)
renaming the module
removing pro-compile conditional statements
moving extraction code to a new database
extracting from database with only problem module plus module with comments
repair MS Office
reinstall MS Office
downgrade Windows updates
Does anyone have any idea why this might be failing? Any suggestions on how to rectify would be really appreciated.

runtime error 13 type mismatch vba while downloading mutliple files from web

I created a macro for a file and first it was working fine, but today I've been opening and restarting the file and macro hundreds of times and I'm always getting the following error:
Excel VBA Run-time error '13' Type mismatch
I didn't change anything in the macro and don't know why am I getting the error. Furthermore it takes ages to update the macro every time I put it running (the macro has to run about 9000 rows).
ERROR is somewhere "FileData = WHTTP.ResponseBody"
Sub Test2()
Dim A As Long
Dim FileNum As Long
Dim FileData() As Byte
Dim MyFile As String
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
If Err.Number <> 0 Then
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
End If
On Error GoTo 0
If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads"
For A = 1 To 228
MyFile = Cells(A, 1).Text
TempFile = Right(MyFile, InStr(1, StrReverse(MyFile), "/") - 1)
WHTTP.Open "GET", MyFile, False
WHTTP.Send
FileData = WHTTP.ResponseBody
FileNum = FreeFile
Open "C:\MyDownloads\" & TempFile For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
Next
Set WHTTP = Nothing
MsgBox "Open the folder [ C:\MyDownloads ] for the downloaded file..."
End Sub
Put On Error Resume Next above the line causing an error (probably this line WHTTP.Send). Put this block of code after your line with an error.
Files/Web Addresses/Registry keys - YOU MUST ASSUME IT MAY NOT WORK and trap errors so you know why (and where it's not working). Usually these are not programming questions.
If err.number <> 0 then
ERRString = ErrString & ""
ERRString = ErrString & "Error getting file"
ERRString = ErrString & "=================="
ERRString = ErrString & ""
ERRString = ErrString & "Error " & err.number & "(0x" & hex(err.number) & ") " & err.description
ERRString = ErrString & "Source " & err.source
ERRString = ErrString & ""
ERRString = ErrString & "HTTP Error " & WHTTP.Status & " " & WHTTP.StatusText
ERRString = ErrString & WHTTP.getAllResponseHeaders
Msgbox ErrString
End If
Just download direct using API call and URL
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const folderName As String = "C:\Users\User\Desktop\Blah.zip" '<== Change to destination
Public Sub downloadIFolder()
Dim ret As Long
ret = URLDownloadToFile(0, "http://www.bseindia.com/BSEDATA/margins/VAR290716.zip", folderName, BINDF_GETNEWESTVERSION, 0)
MsgBox ret
End Sub

Error Running Vba Code

#If Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As LongPtr) _
As LongPtr
#Else
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As Long) _
As Long
#End If
Dim Ret As Long
'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\Temp"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
'~~> Name of the sheet which has the list
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
EndSub
enter image description here
Error is given below:
After correcting the parameter in the API function, this is what I used.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Const FolderName As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
End Sub
To have the file path if the download was successfull, try it.
So if the file is downloaded successfully the path will be placed in column C and the msg "File successfully downloaded" in column D otherwise column C will contain "Unable to download the file".
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = strPath
ws.Range("D" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
This worked for me. For more info have a look e.g. here.
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Const FolderName As String = "C:\Temp"
Sub Sample()
Dim Ret As Long
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
Dim urlFileName As String
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
strPath = FolderName & "\" & ws.Range("A" & i).Value & ".jpg"
urlFileName = ws.Range("B" & i).Value
Ret = URLDownloadToFile(0, urlFileName, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
End Sub
Data on Sheet
HeaderA | HeaderB
SomeImage1 | http://www.someaddress.com/Imgs/SomeImage1.jpg

How can I automate the addition from WorkbookConnections with VBA?

I want to connect csv files with excels power pivot with a VBA code by using WorkbookConnection.AddfromFile
My question:
I want to connect numerous csv file. To do so I have to click for hours through the Text Import Wizard. I haven't found out yet how to automatize this! I imagine to do it in a similar way like I did it with the FileDialog in the upper part of my code. Below the part of my code where I want to implement it.
For LoopCounter = 1 To fd.SelectedItems.count
ActiveWorkbook.Connections.AddFromFile _
fd.SelectedItems(LoopCounter), True, False
Next LoopCounter
Below the code I have already written. With this code I have to click through the TextImportWizard manually.
Sub csv()
Dim fd As FileDialog
Dim ActionClicked As Boolean
Dim LoopCounter As Long
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\temp"
fd.AllowMultiSelect = True
fd.Title = "Open your data"
fd.ButtonName = "GO"
ActionClicked = fd.Show
If ActionClicked Then
For LoopCounter = 1 To fd.SelectedItems.count
ActiveWorkbook.Connections.AddFromFile _
fd.SelectedItems(LoopCounter), True, False
Next LoopCounter
Else
MsgBox "You didn't choose anything"
Exit Sub
End If
End Sub
The faster way to import CSV or text files is with the following
Dim InputStringCSV As String
Dim CSVFile As Variant
Dim ArrayStringCSV() As String
CSVFile = Application.GetOpenFilename("CSV Files,*.CSV", Title:="MyData")
If CSVFile = False Then "No input!", vbCritical: End
Open CSVFile For Input As #1
Do Until EOF(1)
Line Input #1, InputStringCSV
ArrayStringCSV = Split(InputStringCSV, Chr(10))
For CounterArray = LBound(ArrayStringCSV) To UBound(ArrayStringCSV)
'Defaults: Row 1 is the beginnning for the sheet
Sheets(Sheet_CSV).Cells(1 + CounterArray, 1).NumberFormat = "#"
Sheets(Sheet_CSV).Cells(1 + CounterArray, 1) = ArrayStringCSV(CounterArray)
Next CounterArray
Loop
Close #1
If you want to automate it for all the CSV files in a folder, I'd suggest that you loop through archives -looking for .csv ones-, here's a sample on how to get you started:
Set oFSO = CreateObject("Scripting.FileSystemObject")
oStartFolder = "C:/Documents"
Set oFolder = oFSO.GetFolder(oStartFolder)
oFSO.GetFolder (oFolder)
For Each FileItem In oFolder.Files
if Instr(FileItem,".csv") Then Call ImportCSV(FileName) 'you would change the above code to don't ask folder and set the argument so each time you call it would be the file csv in the folder
Next FileItem
There are lots of ways to import text files. See the link below.
http://www.rondebruin.nl/win/s3/win022.htm
This AddIn will do the work for you.
http://www.rondebruin.nl/win/addins/rdbmerge.htm
Also, you can merge all your text files in a folder into one worksheet.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername
'Create two temporary file names
BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
'Folder where you want to save the Excel file
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set the extension and file format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007 or higher
FileExtStr = ".xlsx": FileFormatNum = 51
'If you want to save as xls(97-2003 format) in 2007 use
'FileExtStr = ".xls": FileFormatNum = 56
End If
'Name of the Excel file with a date/time stamp
XLSFileName = DefPath & "MasterCSV " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
'Browse to the folder with CSV files
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "\" Then
foldername = foldername & "\"
End If
'Create the bat file
Open BatFileName For Output As #1
Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
& Chr(34) & " " & TXTFileName
Close #1
'Run the Bat file to collect all data from the CSV files into a TXT file
ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If
'Open the TXT file in Excel
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False
'Save text file as a Excel file
Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
Wb.Close savechanges:=False
MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName
'Delete the bat and text file you temporary used
Kill BatFileName
Kill TXTFileName
Application.ScreenUpdating = True
End If
End Sub
You'll find more info here.
http://www.rondebruin.nl/win/s3/win021.htm
If you want to maintain the data connections, like I do, then you need to first make a query using Power Query M formula. Then you can add your connection to that query. This is what Excel does when you use the Get Data wizards.
Use this procedure in your loop and it will make a new sheet for each CSV file:
'#Description("Create a new worksheet with a table that is connected to a CSV file as a data source.")
Public Sub GetDataFromCSV(ByVal name As String, ByVal fileName As String)
On Error GoTo errorHandler
' The Power Query points to the CSV file, if your data contains headers you need the Promoted Headers
Dim csvFormula As String
csvFormula = "let" & vbNewLine & _
" Source = Csv.Document(File.Contents(""" & fileName & """),null,null,null,1252)," & vbNewLine & _
" #""Promoted Headers"" = Table.PromoteHeaders(Source, [PromoteAllScalars=true])" & vbNewLine & _
"in" & vbNewLine & _
" #""Promoted Headers"""
ThisWorkbook.Queries.Add name:=name, Formula:=csvFormula
' The workbook connects to that query
Dim newConnection As WorkbookConnection
Set newConnection = ThisWorkbook.Connections.Add2("Query - " & name, _
"Connection to the '" & name & "' query in the workbook.", _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & name & ";Extended Properties="""";", """" & name & """", 6, True, False)
' I always want one table per sheet that begins at A1
Dim newSheet As Worksheet
Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
newSheet.name = name
' Only once you have the connection backed by the query can you link it to a Table
With newSheet.ListObjects.Add(SourceType:=xlSrcModel, Source:=newConnection, LinkSource:=True, XlListObjectHasHeaders:=xlYes, Destination:=newSheet.Range("$A$1")).TableObject
.RowNumbers = False
.PreserveFormatting = True
.RefreshStyle = 1
.AdjustColumnWidth = True
' I get errors when there are hyphens in the DisplayName, the default behavior of the wizard replaces them with underscors
.ListObject.DisplayName = Replace(name, "-", "_")
.Refresh
End With
Exit Sub
errorHandler:
If Err.Number = -2147024809 Then
' Query already exists, we delete it so we can recreate it
ThisWorkbook.Queries.Item(name).Delete
Resume
Else
Debug.Print "ERROR " & Err.Number & " : " & Err.Description
End If
End Sub

VBA Macro for importing text files into separate Excel workbooks

I have a macro that imports all the text files in one folder onto one Excel sheet. What I want now is that the macro should import all the files into the folder, but into separate Excel workbooks (separate Excel files).
I am attaching the macro here, please help!
P.S. : This macro is not written by me. I found it online, and made some necessary changes to suit my needs.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername
'Create two temporary file names
BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
'Folder where you want to save the Excel file
'DefPath = Application.DefaultFilePath
DefPath = ThisWorkbook.Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set the extension and file format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007 or higher
FileExtStr = ".xlsx": FileFormatNum = 51
'If you want to save as xls(97-2003 format) in 2007 use
'FileExtStr = ".xls": FileFormatNum = 56
End If
'Name of the Excel file with a date/time stamp
XLSFileName = DefPath & "MetaData Collated " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
'Browse to the folder with CSV files
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "\" Then
foldername = foldername & "\"
End If
'Create the bat file
Open BatFileName For Output As #1
Print #1, "Copy " & Chr(34) & foldername & "*.txt" _
& Chr(34) & " " & TXTFileName
Close #1
'Run the Bat file to collect all data from the CSV files into a TXT file
ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If
'Open the TXT file in Excel
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=True, OtherChar:="|"
'Save text file as a Excel file
Set Wb = ActiveWorkbook
Wb.SaveAs FileFormat:=FileFormatNum
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
Wb.Close savechanges:=False
MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName
'Delete the bat and text file you temporary used
Kill BatFileName
Kill TXTFileName
Application.ScreenUpdating = True
End If
End Sub
The following works (tested on .csv files):
Sub test()
Convert "C:\"
End Sub
Sub Convert(strPath As String)
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet
Dim filename, newname
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then Exit Sub
sItem = .SelectedItems(1)
End With
Set fldr = Nothing
filename = Dir(sItem & "\*.*")
While (filename <> "")
Set wbO = Workbooks.Open(sItem & "\" & filename)
If (wbO Is Nothing) Then Exit Sub
pos = InStrRev(filename, ".")
newname = Mid(filename, 1, pos) + "xlsx"
Set wbI = Workbooks.Add
Set wsI = wbI.Sheets("Sheet1")
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
wbI.SaveAs sItem & "\" & newname
wbI.Close
filename = Dir
Wend
End Sub