vba - 如何加速这个 VBA 代码？

Question

excel文件有9张。每张表有 1668 行和 34 个供应商。我想创建一张包含所有数据的工作表。我知道这样会有重复，但现在没关系。有什么办法可以加快代码速度吗？复制大约 510.000 条记录需要很长时间。
(当我尝试使用 for 循环时，您可以在我第一次尝试时看到评论，这不是一个好主意。)

Sub goEasy()

Dim wsText As Variant
Dim sht As Worksheet
Dim wSum As Worksheet
Dim service As String
Dim supplier As String
Dim priceRange As String
Dim price As String
Dim Lrow As Long, LastRow As Long
Dim a As Long, b As Long

Set sht = ThisWorkbook.Worksheets(4)
Set wSum = ThisWorkbook.Worksheets("Summary")

wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M")

LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

For Each element In wsText
    'For i = 5 To LastRow
    a = 4
    b = 12

    Do While a < LastRow
        'For j = 13 To 47

        If a = LastRow Then
            a = 4
            Exit Do
        End If
        a = a + 1

        Do While b <= 47

            If b = 47 Then
                b = 12
                Exit Do
            End If

            b = b + 1
            Lrow = wSum.UsedRange.Rows(wSum.UsedRange.Rows.Count).Row + 1

            service = ThisWorkbook.Worksheets(element).Cells(a, 1).Text
            supplier = ThisWorkbook.Worksheets(element).Cells(4, b).Text
            priceRange = ThisWorkbook.Worksheets(element).Cells(2, 1).Text
            price = ThisWorkbook.Worksheets(element).Cells(a, b).Text

            wSum.Cells(Lrow, 1) = service
            wSum.Cells(Lrow, 2) = supplier
            wSum.Cells(Lrow, 3) = priceRange
            wSum.Cells(Lrow, 4) = price
            'Next j
        Loop

        'Next i
    Loop
Next element


End Sub

Answer 1

请尝试以下代码。 (未测试)
将值写入单元格会消耗时间。将值写入单元格会使您的 VBA 变慢。
通过数组，您只能写入一次单元格。这将节省大量时间。

Sub goEasy()
    dim a as long, b as long, LastRow as long
    dim sht as worksheet, wSum as worksheet
    dim wsText as variant, element as variant, dAry as variant

    set sht = thisworkbook.worksheets(4)
    set wSum = Thisworkbook.worksheets("summary")
    wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M")

    LastRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
    For Each element In wsText
        a = 5
        b = 13
        Do until a > LastRow    'For i = 5 To LastRow
            Do until b > 47    'For j = 13 To 47
                if not isarray(dAry) then
                    redim dAry(3, 0) as variant
                else
                    redim preserve dAry(3, ubound(dAry, 2) + 1) as variant
                end if

                With thisworkbook.Worksheets(element)
                    dAry(0, ubound(dAry,2)) = .Cells(a, 1).Text
                    dAry(1, ubound(dAry,2)) = .Cells(4, b).Text
                    dAry(2, ubound(dAry,2)) = .Cells(2, 1).Text
                    dAry(3, ubound(dAry,2)) = .Cells(a, b).Text
                End With
                b = b + 1    'Next j
            Loop
            b = 13
            a = a + 1    'Next i
        Loop
    Next element
    wSum.Cells(rows.count, 1).end(xlup).offset(1).resize(ubound(dAry,2) + 1, ubound(dAry,1) + 1) = application.transpose(dAry)
End Sub