cmccabe1
01-11-2016, 11:57 AM
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
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