Excel中每10000行的VBA循环代码

Question

我有以下 VB 代码从 Excel WorkBook 生成 CSV 文件。

我的数据非常大，我希望代码每 10000 行开始分块。

我基本上希望它每 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

逐个单元格的访问将非常缓慢：如果您将所有数据读入二维数组并从那里访问，您的代码将运行得更快。

EDIT更新块输出

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