How can I automate the addition from WorkbookConnections with VBA? - vba

Question

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

Answer 1

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

Answer 2

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

Answer 3

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