Код VBA занимает слишком много времени (смещение) Код выполняется в Excel для заполнения строк столбцов таблицы

Question

У меня есть следующий фрагмент кода, который записывает из памяти в строки \ столбцы электронной таблицы.Если есть 200 записей, это займет несколько минут.Я не понимаю, почему так медленно, потому что нет дискового ввода-вывода.Все должно происходить в памяти.Так почему меня бьет несколько минут.

Есть идеи, как сделать это быстрее?Является ли Offset виновником?Кстати, TagValues ​​- это двумерный массив.

Private Sub PopulateGrid()


    Dim i As Integer
    Dim r As Range
    Dim RowOffset As Integer
    Dim CurRow As Integer
    Dim StartCol As String

    RowOffset = 15
    StartCol = "B"

    MsgBox "Grid population will start after you press OK.  This might take a few minutes.  Please wait while we populate the grid.  You will be alerted when completed."

    Set r = ActiveSheet.Range("B16")

    For i = 1 To TotalRecords
        CurRow = RowOffset + i
        Set r = ActiveSheet.Range(StartCol + CStr(CurRow))
        r.Value = TagValues(i, cTagNo)

        Set r = r.Offset(0, 1)
        r.Value = Qty(i)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cSize)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cValveType)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cBodyStyle)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cPressureClass)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cOperator)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cEndConfiguration)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cPort)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cBody)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cTrim)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cStemHingePin)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cWedgeDiscBall)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cSeatRing)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cORing)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cPackingSealing)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cGasket)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cWarrenValveFigureNo)
        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cWarrenValveTrimCode)
        Set r = r.Offset(0, 1)
        r.Value = RemoveLastLineBreakAndTrim(TagValues(i, cComments))

        Set r = r.Offset(0, 1)
        r.Value = TagValues(i, cDelivery)

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = ""

        Set r = r.Offset(0, 1)
        r.Value = Price(i)

        Set r = r.Offset(0, 1)
        r.Value = ExtPrice(i)

    Next

    MsgBox "Grid Population completed."

End Sub

Answer 1

Быстрее всего создать двумерный массив нужного размера в памяти, заполнить его из исходных данных, а затем перетащить прямо на рабочий лист.

Не проверено:

Private Sub PopulateGrid()

    Const RowOffset As Long = 15
    Const StartCol As String = "B"
    Const NUMCOLS As Long = 5

    Dim i As Integer
    Dim arrOut()

    ReDim arrOut(1 To totalrecords, 1 To NUMCOLS)

    For i = 1 To totalrecords

        'shorter set of columns to illustrate the approach...
        arrOut(i, 1) = TagValues(i, cTagNo)
        arrOut(i, 2) = Qty(i)
        arrOut(i, 3) = TagValues(i, cSize)
        arrOut(i, 4) = TagValues(i, cValveType)
        arrOut(i, 5) = TagValues(i, cBodyStyle)

    Next

    ActiveSheet.Range("B16").Resize(totalrecords, NUMCOLS).Value = arrOut

End Sub

Answer 2

Трудно понять, не видя данных, с которыми вы работаете, но вот пара вещей, которые должны помочь:

Sub test()

    ' Disable visual and calc functions
    ' So Excel isn't updating the display and
    ' recalculating formulas every time you
    ' fill another cell
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Instead of resetting r each time,
    ' Try more like this:
    Set r = ActiveSheet.Range(StartCol + CStr(CurRow))
    r.Value = TagValues(i, cTagNo)

    r.Offset(0, 1).Value = TagValues(i, cSize)
    r.Offset(0, 2).Value = TagValues(i, cValveType)
    r.Offset(0, 3).Value = TagValues(i, cBodyStyle)
    ' etc, etc, etc.
    ' Less steps for the processor
    ' Easier maintenance for you


    ' Enable visual and calc functions
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic   



End Sub