vba - 在工作簿中保存不在目录中为 xlsx

Question

以下vba将解析后的输出保存在工作簿中而不是 myDir 中目录为 xlsx我似乎无法弄清楚。它似乎除此之外都起作用，我需要一些专家的帮助来弄清楚最后一部分。基本上，每个 txt myDir 中的文件被解析，然后 txt文件被解析为 xlsx .目前，正在发生的是第一个 txt文件在 myDir正在被解析并保存在工作簿中，然后 vba退出。

编辑
下面的 vba 运行，但在工作簿的工作表中显示解析的输出，而不是在 myDir 中保存为 xlsx。

`ActiveWorkbook.SaveAs Filename:=Replace(fn, ".txt", ""), FileFormat:=xlOpenXMLWorkbook' 
stepping-through the vba I can see that fn has the full path and the filename but not sure why it does not save to myDir as an xlsx.

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

结束子

Answer 1

您正在传递 myDir & fn作为 的参数创建 XLSX 文件 程序。该参数称为fn在那个过程中。您没有在任何地方声明或分配 myDir 中的变量创建 XLSX 文件 程序。

“最佳实践”可能是完全删除扩展名并允许 文件格式 Workbook.SaveAs method 的参数通过适当的XlFileFormat Enumeration设置它持续的。在这种情况下， xlOpenXMLWorkbook (例如 51 )将是合适的。

ActiveWorkbook.SaveAs Filename:=Replace(fn, ".txt", ""), FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False

简而言之，您试图在另一个过程中使用在一个过程中声明和分配的变量。使用 Option Explicit在模块代码表的顶部以避免这些类型的错误或使用 VBE 的工具、选项、编辑器、需要变量声明。如果你设置 FileFormat 和那个参数来确定文件扩展名，你应该很好。

附录:

我没有对您的主要调用程序给予太多关注。仔细检查发现了一个离散但关键的缺陷。

 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 = Dir '<~~ get the next filename from DIR, not reassigned to myDir!!!
     Loop 

 End Sub 

它最初重新分配 值的方式我的目录 至 fn 不会把你带到任何地方。这应该是相当简单的调试方法揭示 的新值fn .

放在一起

Private Sub CommandButton1_Click()
    Dim myDir As String, fn As String
    myDir = "C:\Users\cmccabe\Desktop\EmArray\"
    fn = Dir(myDir & "file*.txt")
    Do While fn <> ""
       CreateXLSXFiles myDir & fn
       fn = Dir
    Loop
 End Sub

 Sub CreateXLSXFiles(fn As String)
     Dim txt As String, m As Object, n As Long, fp 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")

    fp = "C:\Users\cmccabe\Desktop\EmArray\"

    With Worksheets(1)
        .Cells.Clear
        .Name = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)

        'RegEx stuff going on here

        .Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=fp & .Name, _
                              FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close False
        Application.DisplayAlerts = True
    End With
End Sub