PDA

View Full Version : Refine code to combine multiple CSV files into single workbook



leal72
11-08-2016, 09:33 AM
I have this code to combine multiple CSV files into a single workbook. It works as intended but I was wondering if I could refine it in anyway to possibly have it run any quicker? And also if it could be done without ending up with a blank sheet?

Thank you for looking


Sub CEAST_9340_WIP()' Charts on specimen #1 worksheet


Dim WkbName As String
Dim NewWkb As Workbook
Dim CSVfiles As Variant
Dim FileCount As Long
Dim WkbTemp As Workbook
Dim WsName As String
Dim LotNumber As String
Dim SpecimenNumber As String


Application.ScreenUpdating = False


' User Input box to name workbook
WkbName = InputBox("Name the workbook to store test data", "WORKBOOK NAME")

' Create new workbook with single worksheet
Set NewWkb = Workbooks.Add(xlWBATWorksheet)

' Exit if dialog box canceled


If WkbName <> "" Then
NewWkb.SaveAs FileName:=WkbName ' Save workbook with InputBox info
WkbName = NewWkb.Name
Else
NewWkb.Close ' Close created workbook if InputBox is cancelled
Exit Sub
End If

' Rename Sheet1
'Workbooks(WkbName).Sheets(1).Name = "SummaryData"

' Select Raw Data (*.csv) files
CSVfiles = Application.GetOpenFilename _
("Comma Separated Values File (*.csv), *.csv", _
Title:="Select which data files to import", MultiSelect:=True)

' Exit macro if no files were selected
If Not IsArray(CSVfiles) Then
MsgBox "No file was selected."
Exit Sub
End If

' Loop through selected files and add to Results workbook
For FileCount = LBound(CSVfiles) To UBound(CSVfiles)

Set WkbTemp = Workbooks.Open(FileName:=CSVfiles(FileCount))

Workbooks.OpenText FileName:=CSVfiles(FileCount), _
Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True


' Moves active sheet to named workbook
ActiveSheet.Move before:=Workbooks(WkbName).Sheets(FileCount)

If Not ActiveSheet.Range("A2") = "" Then
LotNumber = GetNumbers(ActiveSheet.Range("A1").Value)
SpecimenNumber = GetNumbers(ActiveSheet.Range("A2").Value)
WsName = LotNumber & "_" & SpecimenNumber
ActiveSheet.Name = WsName
Else
WsName = ActiveSheet.Name
End If

Next FileCount



End Sub
Function GetNumbers(Number As String)


Dim z As Long
Dim x As Long
Dim Nmb As String
Dim NewNmb As String


x = Len(Number)
For z = 1 To x
Nmb = Mid(Number, z, 1)
If IsNumeric(Nmb) Then
NewNmb = NewNmb & Nmb
End If
Next z

GetNumbers = NewNmb

End Function

Kenneth Hobs
11-08-2016, 07:42 PM
Maybe this method will run a bit faster.

'http://analystcave.com/merge-csv-files-or-txt-files-in-a-folder/
Sub Test_MergeFiles()
Dim fileNames(0 To 1) As String

fileNames(0) = "C:\somefolder\test.csv"
fileNames(1) = "C:\somefolder\test1.csv"

MergeFiles fileNames, "C:\Merged.csv", True, False
End Sub


'http://www.excelforum.com/excel-programming-vba-macros/1161879-merge-select-csv-txt-files.html
Sub AlphaFrog()
Dim s() As String, i As Long, fn As String

fn = ThisWorkbook.Path & "\Merged.csv"

' Prompt user to select files
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = ThisWorkbook.Path ' Default path
.FilterIndex = 6 'CSV files
.Title = "Please Select CSV Files to Merge (Ctrl+Click to multi-select files)"
'.ButtonName = "Open"
.AllowMultiSelect = True
.Show
If .SelectedItems.Count = 0 Then Exit Sub ' User clicked cancel

'Convert poke variant array data to string array.
ReDim s(1 To .SelectedItems.Count) As String
For i = 1 To .SelectedItems.Count
s(i) = .SelectedItems(i)
Next i
End With


MergeFiles s(), fn

Shell "cmd /c " & fn, vbNormal
End Sub


'http://analystcave.com/merge-csv-files-or-txt-files-in-a-folder/
Sub MergeFiles(fileNames() As String, newFileName As String, Optional headers As Boolean = True, Optional addNewLine As Boolean = False)
Dim fileName As Variant, textData As String, fileNo As Integer, result As String, firstHeader As Boolean

firstHeader = True
For Each fileName In fileNames
fileNo = FreeFile
Open fileName For Input As #fileNo
textData = Input$(LOF(fileNo), fileNo)
Close #fileNo
If headers Then
'result = result & IIf(addNewLine, vbNewLine, "") & IIf(firstHeader, textData, right(textData, Len(textData) - InStr(textData, vbNewLine)))
result = result & IIf(addNewLine, vbNewLine, "") & IIf(firstHeader, textData, Right(textData, Len(textData) - InStr(textData, vbNewLine) - 1))
firstHeader = False
Else
result = result & IIf(addNewLine, vbNewLine, "") & textData
End If
Next fileName

fileNo = FreeFile
Open newFileName For Output As #fileNo
Print #fileNo, result
Close #fileNo
End Sub

snb
11-09-2016, 04:36 AM
I'd use:


Sub M_snb()
Set fs = CreateObject("scripting.filesystemobject")

With Application.FileDialog(1)
.AllowMultiSelect = True
If .Show Then
For Each it In .SelectedItems
c00 = c00 & fs.opentextfile(it).readall
Next
fs.createtextfile("G:\OF\all_001.csv").write c00
End If
End With

Workbooks.Open "G:\OF\all_001.csv"
End Sub

If all csv files in a certain folder have to be merged the code can be more simple.

leal72
11-09-2016, 08:38 AM
I'd use:


Sub M_snb()
Set fs = CreateObject("scripting.filesystemobject")

With Application.FileDialog(1)
.AllowMultiSelect = True
If .Show Then
For Each it In .SelectedItems
c00 = c00 & fs.opentextfile(it).readall
Next
fs.createtextfile("G:\OF\all_001.csv").write c00
End If
End With

Workbooks.Open "G:\OF\all_001.csv"
End Sub

If all csv files in a certain folder have to be merged the code can be more simple.

Thank you. It does run a little quicker but puts all the data on the same worksheet. I need it to place each CSV file on its own worksheet. I do appreciate the help

leal72
11-09-2016, 08:44 AM
Maybe this method will run a bit faster.

'http://analystcave.com/merge-csv-files-or-txt-files-in-a-folder/
Sub Test_MergeFiles()
Dim fileNames(0 To 1) As String

fileNames(0) = "C:\somefolder\test.csv"
fileNames(1) = "C:\somefolder\test1.csv"

MergeFiles fileNames, "C:\Merged.csv", True, False
End Sub


'http://www.excelforum.com/excel-programming-vba-macros/1161879-merge-select-csv-txt-files.html
Sub AlphaFrog()
Dim s() As String, i As Long, fn As String

fn = ThisWorkbook.Path & "\Merged.csv"

' Prompt user to select files
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = ThisWorkbook.Path ' Default path
.FilterIndex = 6 'CSV files
.Title = "Please Select CSV Files to Merge (Ctrl+Click to multi-select files)"
'.ButtonName = "Open"
.AllowMultiSelect = True
.Show
If .SelectedItems.Count = 0 Then Exit Sub ' User clicked cancel

'Convert poke variant array data to string array.
ReDim s(1 To .SelectedItems.Count) As String
For i = 1 To .SelectedItems.Count
s(i) = .SelectedItems(i)
Next i
End With


MergeFiles s(), fn

Shell "cmd /c " & fn, vbNormal
End Sub


'http://analystcave.com/merge-csv-files-or-txt-files-in-a-folder/
Sub MergeFiles(fileNames() As String, newFileName As String, Optional headers As Boolean = True, Optional addNewLine As Boolean = False)
Dim fileName As Variant, textData As String, fileNo As Integer, result As String, firstHeader As Boolean

firstHeader = True
For Each fileName In fileNames
fileNo = FreeFile
Open fileName For Input As #fileNo
textData = Input$(LOF(fileNo), fileNo)
Close #fileNo
If headers Then
'result = result & IIf(addNewLine, vbNewLine, "") & IIf(firstHeader, textData, right(textData, Len(textData) - InStr(textData, vbNewLine)))
result = result & IIf(addNewLine, vbNewLine, "") & IIf(firstHeader, textData, Right(textData, Len(textData) - InStr(textData, vbNewLine) - 1))
firstHeader = False
Else
result = result & IIf(addNewLine, vbNewLine, "") & textData
End If
Next fileName

fileNo = FreeFile
Open newFileName For Output As #fileNo
Print #fileNo, result
Close #fileNo
End Sub




Appreciate your time. I'll go through these. Thank you

Kenneth Hobs
11-09-2016, 09:05 AM
Sounds like this might be a better fit for you. http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/merge-functions/csvs-to-sheets

leal72
11-09-2016, 10:31 AM
Sounds like this might be a better fit for you. http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/merge-functions/csvs-to-sheets

Thank you

snb
11-09-2016, 01:13 PM
Please do not quote !


Sub M_snb()
With Application.FileDialog(1)
.AllowMultiSelect = True
If .Show Then
For Each it In .SelectedItems
thisworkbook.sheets.add ,sheets(sheets.count),,it
Next
End If
End With
End Sub