error parsing text files in directory using excel 2010 vba

[cmccabe1]

In the below vba I get a run-time invalid name for sheet error on

Sheets(1).Name = CreateObject("Scripting.FileSystemObject").GetBaseName(fn) . Since there and two text files in the directory fn=file1.txtfile2.txt, is that the problem is the VBA not able to read the individual file correctly? Basically, each txt file (up to 8) in the myDir is parsed and then the txt file in myDir is replaced with the parsed xlsx. Thank you :).

VBA


Option Explicit
Private Sub CommandButton21_Click()
Dim myDir As String, fn As String
myDir = "C:\Users\cmccabe\Desktop\EmArray\"
fn = Dir(myDir & "*.txt")
Do While fn <> ""
CreateXLSXFiles Dir & fn
fn = Dir
Loop
End Sub
Sub CreateXLSXFiles(fn As String)
Dim txt As String, m As Object, n As Long
Dim i As Long, x, temp, ub As Long, myList
myList = Array("Display Name", "Medical Record", "Date of Birth", "Order Date", _
"Gender", "Barcode", "Sample", "Build", "SpikeIn", "Location", "Control Gender", "Quality")
Sheets(1).Cells.Clear
Sheets(1).Name = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
On Error Resume Next
n = FileLen(fn)
If Err Then
MsgBox "Something wrong with " & fn
Exit Sub
End If
On Error GoTo 0
n = 0
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
For i = 0 To UBound(myList)
.Pattern = "^#(" & myList(i) & " = (.*))"
If .test(txt) Then
n = n + 1
Sheets(1).Cells(n, 1).Resize(, 2).Value = _
Array(.Execute(txt)(0).submatches(0), .Execute(txt)(0).submatches(1))
End If
Next
.Pattern = "^[^#\r\n](.*[\r\n]+.+)+"
x = Split(.Execute(txt)(0), vbCrLf)
.Pattern = "(\t| {2,})"
temp = Split(.Replace(x(0), Chr(2)), Chr(2))
n = n + 1
For i = 0 To UBound(temp)
Sheets(1).Cells(n, i + 1).Value = temp(i)
Next
ub = UBound(temp)
.Pattern = "((\t| {2,})| (?=(\d|"")))"
For i = 1 To UBound(x)
temp = Split(.Replace(x(i), Chr(2)), Chr(2))
n = n + 1
Sheets(1).Cells(n, 1).Resize(, ub).Value = temp
Next
End With
Sheets(1).Copy
ActiveWorkbook.SaveAs Filename:=Replace(fn, ".txt", ""), FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
End Sub

[snb]

Sheets(1).Name = CreateObject("Scripting.FileSystemObject").GetBaseName(mydir & "\" & fn)

[cmccabe1]

I am getting the same error with that change as well. Thank you :).

[Paul_Hossler]

What does debug show for


CreateObject("Scripting.FileSystemObject").GetBaseName(fn)

when you get the error?

[snb]

Please read carefully :

CreateXLSXFiles myDir & fn

[cmccabe1]

My apologies, I missed that: the vba below runs but displays the parsed output in the sheet of the workbook and not saved as an xlsx in the myDir.


ActiveWorkbook.SaveAs Filename:=Replace(fn, ".txt", ""), FileFormat:=xlOpenXMLWorkbook is the line that is highlighted, but I can see the path and original filename there.... but its for whatever reason it doesn't save. Thank you :).



Option Explicit
Private Sub CommandButton21_Click()
Dim myDir As String, fn As String
myDir = "C:\Users\cmccabe\Desktop\EmArray\"
fn = Dir(myDir & "*.txt")
Do While fn <> ""
CreateXLSXFiles myDir & fn
fn = myDir
Loop
End Sub
Sub CreateXLSXFiles(fn As String)
Dim txt As String, m As Object, n As Long, myDir As String
Dim i As Long, x, temp, ub As Long, myList
myList = Array("Display Name", "Medical Record", "Date of Birth", "Order Date", _
"Gender", "Barcode", "Sample", "Build", "SpikeIn", "Location", "Control Gender", "Quality")
myDir = "C:\Users\cmccabe\Desktop\EmArray\"
Sheets(1).Cells.Clear
Sheets(1).Name = CreateObject("Scripting.FileSystemObject").GetBaseName(myDir & fn)
On Error Resume Next
n = FileLen(fn)
If Err Then
MsgBox "Something wrong with " & fn
Exit Sub
End If
On Error GoTo 0
n = 0
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
For i = 0 To UBound(myList)
.Pattern = "^#(" & myList(i) & " = (.*))"
If .test(txt) Then
n = n + 1
Sheets(1).Cells(n, 1).Resize(, 2).Value = _
Array(.Execute(txt)(0).submatches(0), .Execute(txt)(0).submatches(1))
End If
Next
.Pattern = "^[^#\r\n](.*[\r\n]+.+)+"
x = Split(.Execute(txt)(0), vbCrLf)
.Pattern = "(\t| {2,})"
temp = Split(.Replace(x(0), Chr(2)), Chr(2))
n = n + 1
For i = 0 To UBound(temp)
Sheets(1).Cells(n, i + 1).Value = temp(i)
Next
ub = UBound(temp)
.Pattern = "((\t| {2,})| (?=(\d|"")))"
For i = 1 To UBound(x)
temp = Split(.Replace(x(i), Chr(2)), Chr(2))
n = n + 1
Sheets(1).Cells(n, 1).Resize(, ub).Value = temp
Next
End With
Sheets(1).Copy
ActiveWorkbook.SaveAs Filename:=Replace(fn, ".txt", ""), FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
End Sub