以波浪号分隔的出口

Question

我首先在Excel中创建文件。此宏将所有工作表保存到单独的制表符分隔的文本文件中。

如何保存波浪号“〜”而不是制表符？

Sub newworkbooks()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         '      End With
        On Error Resume Next '<< a folder exists
        MkDir MyFilePath '<< create a folder
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                 'save book in this folder
                .saveas Filename:=MyFilePath _
                & "\PO" & SheetName & ".txt", FileFormat:=xlTextWindows
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sheet1.Activate

End Sub

而不是像下面这样

this   is   a   test

应该看起来像这样

this~is~a~test

Answer 1

这里是一种方法，可以很容易地对其进行修改以适合您-这使您可以控制字符集和定界符：

https://excel.solutions/2014/04/using-vba-write-excel-data-to-text-file/

Sub WriteTextFile()

Dim rng As Range, lRow As Long
Dim stOutput As String, stNextLine As String, stSeparator As String
Dim stFilename As String, stEncoding As String
Dim fso As Object

'-------------------------------------------------------------------------------------
'CHANGE THESE PARAMETERS TO SUIT
Set rng = ActiveSheet.UsedRange 'this is the range which will be written to text file
stFilename = "C:\Temp\TextOutput.txt" 'this is the text file path / name
stSeparator = vbTab 'e.g. for comma seperated value, change this to ","
stEncoding = "UTF-8" 'e.g. "UTF-8", "ASCII"
'-------------------------------------------------------------------------------------

For lRow = 1 To rng.Rows.Count
    If rng.Columns.Count = 1 Then
        stNextLine = rng.Rows(lRow).Value
    Else
        stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
    End If
    If stOutput = "" Then
        stOutput = stNextLine
    Else
        stOutput = stOutput & vbCrLf & stNextLine
    End If
Next lRow

Set fso = CreateObject("ADODB.Stream")
With fso
    .Type = 2
    .Charset = stEncoding
    .Open
    .WriteText stOutput
    .SaveToFile stFilename, 2
End With
Set fso = Nothing

End Sub

我确定您可以对其进行调整以遍历您的工作表，并输出每个工作表的UsedRange。

编辑：

这里是如何将其改编为使用代字号作为分隔符，并循环遍历每个工作表；

Sub OutputAllSheetsTildeSeparated()

    Dim rng As Range, lRow As Long
    Dim stOutput As String, stNextLine As String, stSeparator As String
    Dim stFilepath As String, stFilename As String, stEncoding As String
    Dim ws As Worksheet
    Dim fso As Object

    stFilepath = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    stSeparator = "~"
    stEncoding = "UTF-8"

    If Dir(stFilepath, vbDirectory) = vbNullString Then MkDir stFilepath

    For Each ws In ThisWorkbook.Worksheets
        Set rng = ws.UsedRange
        stFilename = stFilepath & "\PO" & ws.Name & ".txt"

        For lRow = 1 To rng.Rows.Count
            If rng.Columns.Count = 1 Then
                stNextLine = rng.Rows(lRow).Value
            Else
                stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
            End If
            If stOutput = "" Then
                stOutput = stNextLine
            Else
                stOutput = stOutput & vbCrLf & stNextLine
            End If
        Next lRow

        Set fso = CreateObject("ADODB.Stream")
        With fso
            .Type = 2
            .Charset = stEncoding
            .Open
            .WriteText stOutput
            .SaveToFile stFilename, 2
        End With
        Set fso = Nothing

    Next ws

End Sub