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

Question

下面的vba 将解析后的输出保存在工作簿中而不是myDir 目录中作为xlsx，我似乎无法弄清楚。它似乎除此之外都起作用，我需要一些专家的帮助来弄清楚最后一部分。基本上，解析myDir 中的每个txt 文件，然后将txt 文件替换为解析后的xlsx。目前，正在发生的事情是myDir 中的第一个txt 文件正在被解析并保存在工作簿中，然后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 作为参数传递给 CreateXLSXFiles 过程。该参数在该过程中称为fn。您没有在 CreateXLSXFiles 过程中声明或分配 myDir 变量。

“最佳实践”可能是完全删除扩展名，并允许Workbook.SaveAs method 的FileFormat 参数通过适当的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 

最初将 myDir 的值重新分配给 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