Question

我需要的帮助是使用下面的宏。我首先在excel中创建文件，这个宏以文本格式保存它们。从宏中可以看出，它将所有工作表保存为带制表符分隔的单个文本文件。

如何更改此宏以使用波浪号保存＆＃34;〜＆＃34;而不是标签？

    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。

修改

以下是如何调整它以使用tilde作为分隔符，并循环遍历每个工作表;

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

Excel宏以波形符分隔的方式导出

1 个答案: