Есть ли более быстрый способ создать текстовый файл? - PullRequest
Новая
       36

Есть ли более быстрый способ создать текстовый файл?

0 голосов
/ 06 февраля 2019

В моем макросе Excel пользователь хотел бы, чтобы он создал текстовый файл результатов.Я могу сделать это с кодом ниже.В настоящее время создание текстового файла с 110 000 строк занимает около 5 минут.Я боюсь, что пользователь будет жаловаться на время, которое требуется.Мне интересно, есть ли лучший / более быстрый способ создать этот текстовый файл?

Заранее спасибо за помощь .... 

Sub Create_Text_File()

    Application.ScreenUpdating = False

    ThisBook = ""
    ThisBook = ActiveWorkbook.Name

    Worksheets("Results").Activate
    r = 2

    Dim X As Long
    X = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

    If X > 1 Then

        MyPath = ""
        MyPath = ActiveWorkbook.Path
        MyPath = MyPath & "\"

        Load frmBank
        frmBank.Show

        On Error Resume Next

        Dim efs As Object
        Dim edump As Object
        Dim eWriteString As String
        Dim eRundate

        eRundate = Year(Date)
        If Len(Month(Date)) = 1 Then eRundate = eRundate & 0

        eRundate = eRundate & Month(Date)
        If Len(Day(Date)) = 1 Then eRundate = eRundate & 0

        eRundate = eRundate & Day(Date)
        If Len(Hour(Time)) = 1 Then eRundate = eRundate & 0

        eRundate = eRundate & Hour(Time)
        If Len(Minute(Time)) = 1 Then eRundate = eRundate & 0

        eRundate = eRundate & Minute(Time)
        If Len(Second(Time)) = 1 Then eRundate = eRundate & 0

        eRundate = eRundate & Second(Time)

        Randomize
        eRandom = Int((99999 - 11111 + 1) * Rnd + 11111)

        Set efs = CreateObject("Scripting.FileSystemObject")

        MyFileName = MyPath & MyBank & " - " & eRundate & "-" & eRandom & ".txt"

        Set edump = efs.createtextfile(MyFileName, False)

        Do Until Len(Trim(Cells(r, 1))) + Len(Trim(Cells(r, 2))) + Len(Trim(Cells(r, 3))) = 0

            eString = Chr(34) & Cells(r, 1) & Chr(34) & Chr(44) & Chr(34) & Cells(r, 2) & Chr(34) & Chr(44) & Chr(34) & Cells(r, 3) & Chr(34)

            If Len(Trim(Cells((r + 1), 1))) > 0 Then

                eString = eString & Chr(13) + Chr(10)

            End If

            eWriteString = eString

            edump.Write eWriteString

            r = r + 1

        Loop

        edump.Close

        MsgBox "  The txt file has been created.", vbExclamation, "Txt File Created"

    Else


        MsgBox "  The txt file was not created as there is no data on the 'Results' sheet.", vbCritical, "Txt File Not Created"

    End If

End Sub
...