Refine code to combine multiple CSV files into single workbook

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

Code:

---

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

---

Maybe this method will run a bit faster.

Code:

---

'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

---

I'd use:

Code:

---

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.

Quote:

---

Originally Posted by snb

I'd use:

Code:

---

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

Quote:

---

Originally Posted by Kenneth Hobs

Maybe this method will run a bit faster.

Code:

---

'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

Sounds like this might be a better fit for you. http://sites.madrocketscientist.com/...csvs-to-sheets

Quote:

---

Originally Posted by Kenneth Hobs

Sounds like this might be a better fit for you. http://sites.madrocketscientist.com/...csvs-to-sheets

---

Thank you

Please do not quote !

Code:

---

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

---