vba code taking too long (Offset) Code running in

问题:

I have following piece of code that writes from memory into rows\columns of a spreadsheet. If there are 200 records, it takes several minutes. I do not understand why it should be that slow BECAUSE there is no disk I/O. Everything should be happening in memory. So why it takes several minutes beats me.

Any ideas on how to make it faster? Is Offset the culprit? BTW, TagValues is a two dimensional array.

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

回答1:

It's hard to know without seeing the data with which you're working, but here are a couple things that should help:

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

回答2:

It would fastest to create a 2-D array of the required size in-memory, fill it from your source data, then drop it directly onto the worksheet.

Untested:

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