如何將每個單獨的工作表保存爲一個txt文件

Question

我有一個代碼可以創建特定格式的工作表，然後將其保存爲文本文件。我一直使用Sheet.SaveAs，然後以不同的方式命名文件。有沒有更強大的方式來保存文件並移動它們？我當前的代碼運行如下：

OldPath = ThisWorkbook.Path & "\"  ' current path to this workbook 
    OldFile = OldPath & ShtName & ".txt" ' location of file upon creation 

    NewPath = OldPath & FldName & "\"  ' path for the folder where file will be moved 
    NewFile = NewPath & ShtName & ".txt" ' location of file after moving 
                          '[3] CREATE INPUT FILES 
    ThisWorkbook.Sheets(ShtName).SaveAs OldFile, FileFormat:=xlTextWindows 
    ThisWorkbook.SaveAs OldPath & ThisFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled 

    If Len(Dir(NewPath, vbDirectory)) <> 0 And NewPath <> "" Then 'MOVE FILES TO A FOLDER 
    Else 
     MkDir NewPath ' create folder for input files to be moved if not yet created 
    End If 

    If Len(Dir(NewFile)) <> 0 Then 
    ' delete an old version of file if it is already in folder 
     SetAttr NewFile, vbNormal 
     Kill NewFile 
    End If 

    Name OldFile As NewFile 

這種方法感覺很麻煩，但我不希望有訴諸使用殼牌，因爲我覺得這將是不太可靠的，除非有人建議來代替。

Answer 1

您可以使用一個通用的文本打印機，以及PrintOut方法來實現這一

首先，如果你沒有帶已經添加一個通用文本打印機

1. 從Add Printer對話框中，選擇File端口
2. 選擇Generic然後Generic/Text Only
3. 它命名爲您希望

此代碼發送每個工作表到這臺打印機

Sub SaveWorkbookAsText(wb As Workbook, Optional FldName As String = vbNullString) 
    Dim NewPath As String 
    Dim GenericTextOnlyPrinter As String 
    Dim ws As Worksheet 

    '<~~~ Change this string to match your Generic Text Only Printer Name 
    GenericTextOnlyPrinter = "Text Only (File)" 

    NewPath = ThisWorkbook.Path & Application.PathSeparator 

    If FldName <> vbNullString Then 
     NewPath = NewPath & FldName 
     If Right$(NewPath, 1) <> Application.PathSeparator Then 
      NewPath = NewPath & Application.PathSeparator 
     End If 
    End If 

    For Each ws In wb.Worksheets 
     ws.PrintOut _ 
      ActivePrinter:=GenericTextOnlyPrinter, _ 
      PrintToFile:=True, _ 
      PrToFileName:=NewPath & ws.Name & ".txt", _ 
      IgnorePrintAreas:=True 
    Next 
End Sub 

---

或者，而不取決於在打印機上，生成在代碼

Sub SaveWorkbookAsText(wb As Workbook, Optional FldName As String = vbNullString) 
    Dim NewPath As String 
    Dim ws As Worksheet 
    Dim dat As Variant 
    Dim rw As Long, cl As Long 
    Dim FileNum As Integer 
    Dim Line As String 

    NewPath = ThisWorkbook.Path & Application.PathSeparator 

    If FldName <> vbNullString Then 
     NewPath = NewPath & FldName 
     If Right$(NewPath, 1) <> Application.PathSeparator Then 
      NewPath = NewPath & Application.PathSeparator 
     End If 
    End If 

    For Each ws In wb.Worksheets 
     FileNum = FreeFile 
     Open NewPath & ws.Name & ".txt" For Output As #FileNum ' creates the file 

     dat = ws.UsedRange.Value 
     ' in case the sheet contains only 0 or 1 cells 
     If TypeName(dat) <> "Variant()" Then 
      dat = ws.UsedRange.Resize(, 2) 
     End If 

     For rw = 1 To UBound(dat, 1) 
      Line = vbNullString 
      For cl = 1 To UBound(dat, 2) - 1 
       Line = Line & dat(rw, cl) & vbTab 
      Next 
      Print #FileNum, Line & dat(rw, cl) 
     Next 
     Close #FileNum 
    Next 
End Sub