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
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