VBA L oop Код для каждых 10000 строк в Excel

Question

У меня есть следующий код VB для создания файла CSV из Excel WorkBook.

Мои данные достаточно велики, и я хотел бы, чтобы код начинал разбиваться на каждые 10000 строк.

Я в основном хочу, чтобы l oop на каждые 10000 строк.

Пожалуйста, помогите.

 Sub PriceList()
    Set objworksheet = ThisWorkbook.Worksheets("Sales Price List")

    output_path = CreateObject("WScript.Shell").specialfolders("Desktop")

    Set myfileFSO = CreateObject("Scripting.FileSystemObject")

    output_file_name = "Sales Price List" & ".txt"

    Set myts = myfileFSO.CreateTextFile(output_path & "\" & output_file_name)


    introw = 1
    Count = 0
    Do Until objworksheet.Cells(introw, 1).Value = ""
        Count = Count + 1
        introw = introw + 1
        Loop


    For i = 4 To Count

    If i = 4 Then

    myts.write "E;" & objworksheet.Cells(i, 1).Value & ";" & objworksheet.Cells(i, 2).Value & ";" _
    & objworksheet.Cells(i, 3).Value & ";" & objworksheet.Cells(i, 4).Value & Chr(13) & Chr(10) & _
    "L;" & objworksheet.Cells(i, 5).Value & ";" & objworksheet.Cells(i, 6).Value & ";" _
    & objworksheet.Cells(i, 7).Value & ";" & objworksheet.Cells(i, 8).Value & ";" & objworksheet.Cells(i, 9).Value _
    & ";" & objworksheet.Cells(i, 10).Value & ";" & objworksheet.Cells(i, 11).Value & ";" & objworksheet.Cells(i, 12).Value _
    & ";" & objworksheet.Cells(i, 13).Value & ";" & objworksheet.Cells(i, 14).Value & ";" & objworksheet.Cells(i, 15) & Chr(13) & Chr(10)

    End If

    If i > 4 Then

    If objworksheet.Cells(i, 2).Value = objworksheet.Cells((i - 1), 2).Value Then

    myts.write "L;" & objworksheet.Cells(i, 5).Value & ";" & objworksheet.Cells(i, 6).Value _
    & ";" & objworksheet.Cells(i, 7).Value & ";" & objworksheet.Cells(i, 8).Value & ";" _
    & objworksheet.Cells(i, 9).Value & ";" & objworksheet.Cells(i, 10).Value & ";" _
    & objworksheet.Cells(i, 11).Value & ";" & objworksheet.Cells(i, 12).Value & ";" _
    & objworksheet.Cells(i, 13).Value & ";" & objworksheet.Cells(i, 14).Value & objworksheet.Cells(i, 15) & Chr(13) & Chr(10)

    Else

    myts.write "E;" & objworksheet.Cells(i, 1).Value & ";" & objworksheet.Cells(i, 2).Value & ";" _
    & objworksheet.Cells(i, 3).Value & ";" & objworksheet.Cells(i, 4).Value & Chr(13) & Chr(10) & _
    "L;" & objworksheet.Cells(i, 5).Value & ";" & objworksheet.Cells(i, 6).Value & ";" _
    & objworksheet.Cells(i, 7).Value & ";" & objworksheet.Cells(i, 8).Value & ";" & objworksheet.Cells(i, 9).Value _
    & ";" & objworksheet.Cells(i, 10).Value & ";" & objworksheet.Cells(i, 11).Value & ";" & objworksheet.Cells(i, 12).Value _
    & ";" & objworksheet.Cells(i, 13).Value & ";" & objworksheet.Cells(i, 14).Value & ";" & objworksheet.Cells(i, 15) & Chr(13) & Chr(10)


    End If

    End If


    Next

     MsgBox "Done."






End Sub 

Answer 1

Этот межклеточный доступ будет очень медленным: ваш код будет работать намного быстрее, если вы прочитаете все данные в двумерный массив и получите к нему доступ оттуда.

РЕДАКТИРОВАТЬ обновить на выходе блока

Sub PriceList()
    Const CHUNK_SIZE As Long = 100
    Dim data, lr As Long, i As Long, repeat As Boolean
    Dim output_path As String, myfileFSO, myts
    Dim ws As Worksheet, chunkNumber As Long

    '** placeholder in output path for chunk number
    output_path = CreateObject("WScript.Shell").specialfolders("Desktop") & _
                                              "\blah\Sales Price List-{chunk}.txt"

    With ThisWorkbook.Worksheets("Sales Price List")
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        data = .Range(.Range("A4"), .Cells(lr, 15)).Value
    End With

    chunkNumber = 1
    Set myts = OutputFile(output_path, chunkNumber)

    For i = 1 To UBound(data, 1)

        'repeat row ?
        repeat = False 'default
        If i > 1 Then repeat = (data(i, 2) = data((i - 1), 2))

        If Not repeat Then
            myts.write Join(Array("E", data(i, 1), data(i, 2), data(i, 3), data(i, 4)), ";") & vbCrLf
        End If

        myts.write Join(Array("L", data(i, 5), data(i, 6), data(i, 7), data(i, 8), _
                                    data(i, 9), data(i, 10), data(i, 11), data(i, 12), _
                                    data(i, 13), data(i, 14), data(i, 15)), ";") & vbCrLf

        If i Mod CHUNK_SIZE = 0 Then
            myts.Close
            chunkNumber = chunkNumber + 1
            Set myts = OutputFile(output_path, chunkNumber)
        End If
    Next

    MsgBox "Done"

End Sub

Function OutputFile(fPath As String, chunkNumber As Long)
    Set OutputFile = CreateObject("Scripting.FileSystemObject"). _
                       CreateTextFile(Replace(fPath, "{chunk}", chunkNumber))
End Function