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

下面的vba将parsing后的输出保存在不在myDir目录下的工作簿中作为xlsx ，我似乎无法弄清楚。 它似乎function，除了这一点，我需要一些专家帮助搞清楚最后一部分。 基本上， myDir中的每个txt文件myDir被parsing，然后txt文件被parsing的xlsxreplace。 目前，正在发生的事情是myDir的第一个txt文件正在parsing并保存在工作簿中，然后vba退出。

编辑下面的运行vba，但在工作簿的工作表中显示parsing的输出，而不是保存为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作为parameter passing给CreateXLSXFiles过程。 该过程中该参数被称为fn 。 在CreateXLSXFiles过程中，无处不在声明或分配myDirvariables。

“最佳做法”可能是完全删除扩展名并允许Workbook.SaveAs方法的FileFormat参数通过适当的XlFileFormat枚举常量进行设置。 在这种情况下， xlOpenXMLWorkbook （例如51 ）将是适当的。

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

简而言之，您正在尝试使用另一个过程中的一个过程中声明和分配的variables。 在模块代码表的顶部使用Option Explicit来避免这些types的错误，或使用VBE的工具，选项，编辑器，需要variables声明。 如果您设置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的方式不会让你得到任何地方。 这应该是相当简单的debugging方法，揭示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