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

Originally Posted by snb

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

Originally Posted by Kenneth Hobs

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/...csvs-to-sheets

**leal72** · 11-09-2016, 10:31 AM

Originally Posted by Kenneth Hobs

Sounds like this might be a better fit for you. http://sites.madrocketscientist.com/...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

Thread: Refine code to combine multiple CSV files into single workbook

Thread Tools

Display

Refine code to combine multiple CSV files into single workbook

Posting Permissions