Merge data

[sukumar.vb]

Dear Gentlemen,

I am working on a VBA program.

I am looking for more better / easy program in VBA only which can IMPORT... 30 csv files (say, sub files) and merges all data into one xls file (say, main file having sheet1: details of file names whom to import ... and sheet2: merged data exactly one after another starting from second row with additional column showing "sub file name" from which data was imported.


Private sub mrg()

With ActiveSheet.QueryTables.Add(Connection:= "TEXT;C:\abc.csv", Destination:=Range("A2"))
.Name = "abc"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub


:think:

[Kenneth Hobs]

There are several ways to do that. Two methods were shown at Excelforum (http://www.excelforum.com/excel-programming/788002-export-data-from-multiple-files-into-a-single-file.html).

[sukumar.vb]

Hi Kenneth, I am requesting reply on this forum. I hope you can help. Query is different, so, method will also be. Please help.

[Aussiebear]

Are the 30 files in one folder or are there all over the place? And could you attach a sample workbook showing the layout you are seeking?

[Kenneth Hobs]

I am not sure why the query is different. I had a commented line for the sql where it got the whole dataset. I removed the schema.ini setup since you did not have a WHERE.

Since I don't have an example to work with, you will have to test.
Sub GetCSVData()
Dim sFilename As String, sql As String
Dim tCell As Range

On Error GoTo EndSub
sFilename = Dir(ThisWorkbook.Path & "\*.csv")
Do While sFilename <> ""
MakeTXTFile ThisWorkbook.Path & "\schema.ini", "[" & sFilename & "]" & vbCrLf & schema
sql = "SELECT * FROM " & """" & sFilename & """"
Set tCell = Range("B" & Rows.Count).End(xlUp).Offset(1)
GetTextFileData sql, ThisWorkbook.Path, tCell
If tCell <> Empty Then Range("A" & tCell.Row).Value2 = GetBaseName(sFilename)
sFilename = Dir()
Loop
ActiveSheet.UsedRange.Columns.AutoFit
EndSub:
End Sub

'http://www.exceltip.com/st/Import_data_from_a_text_file_%28ADO%29_using_VBA_in_Microsoft_Excel/430.html
Sub GetTextFileData(strSQL As String, strFolder As String, _
rngTargetCell As Range, Optional hdr As Boolean = False)
'Tools, References and select Microsoft ActiveX Data Objects x.x Object Library.
' example: GetTextFileData "SELECT * FROM filename.txt", _
"C:\FolderName", Range("A3")
' example: GetTextFileData "SELECT * FROM filename.txt WHERE fieldname = 'criteria'", _
"C:\FolderName", Range("A3")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer
If rngTargetCell Is Nothing Then Exit Sub
Set cn = New ADODB.Connection
On Error Resume Next
cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"Dbq=" & strFolder & ";" & _
"Extensions=asc,csv,tab,txt;"
On Error GoTo 0
If cn.State <> adStateOpen Then Exit Sub
Set rs = New ADODB.Recordset
On Error Resume Next
rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo 0
If rs.State <> adStateOpen Then
cn.Close
Set cn = Nothing
Exit Sub
End If
If hdr Then
' the field headings
For f = 0 To rs.Fields.Count - 1
rngTargetCell.Offset(0, f).Formula = rs.Fields(f).Name
Next f
rngTargetCell.Offset(1, 0).CopyFromRecordset rs ' works in Excel 2000 or later
Else
rngTargetCell.CopyFromRecordset rs
End If
'RS2WS rs, rngTargetCell ' works in Excel 97 or earlier
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Sub MakeTXTFile(filePath As String, str As String)
Dim hFile As Integer
'If Dir(GetFolderName(filePath), vbDirectory) = "" Then
' MsgBox filePath, vbCritical, "Missing Folder"
' Exit Sub
'End If

hFile = FreeFile
Open filePath For Output As #hFile
'If str <> "" Then Write #hFile, , str
If str <> "" Then Print #hFile, str
Close hFile
End Sub

Function GetFileName(Filespec As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
GetFileName = FSO.GetFileName(Filespec)
End Function

Function GetFolderName(Filespec As String) 'Returns path with trailing "\"
'Requires GetFileName() function above
GetFolderName = Left(Filespec, Len(Filespec) - Len(GetFileName(Filespec)))
End Function

Function GetBaseName(Filespec As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
GetBaseName = FSO.GetBaseName(Filespec)
End Function

[sukumar.vb]

Lets assume all CSV files are located in one folder.

[Kenneth Hobs]

That was my assumption when I used ThisWorkbook object. If you want to set some other path, then change the two wb.Path's to your path in the GetCSVData().

I added a routine to fill column A as the previous routine just put the base filename into the first row imported. This method uses UsedRange to get the number of rows imported. You will need to Clear All data and then save the file prior to running the routine sometimes.

Option Explicit

Sub GetCSVData()
Dim sFilename As String, sql As String
Dim tCell As Range, wb As Workbook

Set wb = ThisWorkbook
On Error GoTo EndSub
sFilename = Dir(wb.Path & "\*.csv")
Do While sFilename <> ""
sql = "SELECT * FROM " & """" & sFilename & """"
Set tCell = Range("B" & Rows.Count).End(xlUp).Offset(1)
GetTextFileData sql, wb.Path, tCell
If tCell <> Empty Then Range("A" & tCell.Row).Value2 = GetBaseName(sFilename)
sFilename = Dir()
Loop
FillColumnA
ActiveSheet.UsedRange.Columns.AutoFit
EndSub:

End Sub

'http://www.exceltip.com/st/Import_data_from_a_text_file_%28ADO%29_using_VBA_in_Microsoft_Excel/430.html
Sub GetTextFileData(strSQL As String, strFolder As String, _
rngTargetCell As Range, Optional hdr As Boolean = False)
'Tools, References and select Microsoft ActiveX Data Objects x.x Object Library.
' example: GetTextFileData "SELECT * FROM filename.txt", _
"C:\FolderName", Range("A3")
' example: GetTextFileData "SELECT * FROM filename.txt WHERE fieldname = 'criteria'", _
"C:\FolderName", Range("A3")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer
If rngTargetCell Is Nothing Then Exit Sub
Set cn = New ADODB.Connection
On Error Resume Next
cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"Dbq=" & strFolder & ";" & _
"Extensions=asc,csv,tab,txt;"
On Error GoTo 0
If cn.State <> adStateOpen Then Exit Sub
Set rs = New ADODB.Recordset
On Error Resume Next
rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo 0
If rs.State <> adStateOpen Then
cn.Close
Set cn = Nothing
Exit Sub
End If
If hdr Then
' the field headings
For f = 0 To rs.Fields.Count - 1
rngTargetCell.Offset(0, f).Formula = rs.Fields(f).Name
Next f
rngTargetCell.Offset(1, 0).CopyFromRecordset rs ' works in Excel 2000 or later
Else
rngTargetCell.CopyFromRecordset rs
End If
'RS2WS rs, rngTargetCell ' works in Excel 97 or earlier
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Sub FillColumnA()
Dim s As String, cell As Range, i As Long
s = Range("A2").Value2
For i = 2 To ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1
If Range("A" & i).Value2 = "" Then
Range("A" & i).Value2 = s
Else: s = Range("A" & i).Value2
End If
Next i
End Sub

Sub MakeTXTFile(filePath As String, str As String)
Dim hFile As Integer
'If Dir(GetFolderName(filePath), vbDirectory) = "" Then
' MsgBox filePath, vbCritical, "Missing Folder"
' Exit Sub
'End If

hFile = FreeFile
Open filePath For Output As #hFile
'If str <> "" Then Write #hFile, , str
If str <> "" Then Print #hFile, str
Close hFile
End Sub

Function GetFileName(Filespec As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
GetFileName = FSO.GetFileName(Filespec)
End Function

Function GetFolderName(Filespec As String) 'Returns path with trailing "\"
'Requires GetFileName() function above
GetFolderName = Left(Filespec, Len(Filespec) - Len(GetFileName(Filespec)))
End Function

Function GetBaseName(Filespec As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
GetBaseName = FSO.GetBaseName(Filespec)
End Function

[sukumar.vb]

I will post a very simple and easy solution to above problem. Lets wait for other response(s). Host file's 1st column must be file name of CSV file. Logically, Host file will merge data from CSV file.