Макрос Excel для экспорта в тильде - PullRequest
Новая
       37

Макрос Excel для экспорта в тильде

0 голосов
/ 09 мая 2018

Мне нужна помощь с приведенным ниже макросом. Сначала я создаю файлы в 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

1 Ответ

0 голосов
/ 09 мая 2018

Вот один из подходов, который было бы легко изменить в зависимости от ситуации - он дает вам контроль над набором символов и разделителем:

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 каждого.

EDIT:

Вот как можно адаптировать его для использования тильды в качестве разделителя и циклически проходить по каждому листу; 

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
...