I have a Database worksheet (SoapUI - CollisionsSingle) that have around 1500 records and 38 columns of data per record. I have a VBA script that copies the records into a algorithm worksheet (COL_STpremcalc) and then copies the results back to the database worksheet. However it takes around 1-2 minutes to perform 1 record, and all but breaks my laptop to the point I can't do anything while it runs.

Sub SingleRating()
Dim i As Long
Dim iteration As Variant
Dim seleciton As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("SoapUI - CollisionsSingle")
Set ws2 = Worksheets("COL_STpremcalc")

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False

iteration = 0
iteration = InputBox("Please Select Row Iteration", "", "1")
seleciton = iteration + 3

    For i = 4 To seleciton

        ws2.Range("B3").Value = ws1.Range("D" & i).Value

        ws2.Range("B4").Value = ws1.Range("E" & i).Value

        ws2.Range("B5").Value = ws1.Range("F" & i).Value

        ws2.Range("B6").Value = ws1.Range("G" & i).Value

        ws2.Range("E3").Value = ws1.Range("H" & i).Value

        ws2.Range("E4").Value = ws1.Range("I" & i).Value

        ws2.Range("E5").Value = ws1.Range("J" & i).Value

        ws2.Range("E6").Value = ws1.Range("K" & i).Value

        ws2.Range("G3").Value = ws1.Range("L" & i).Value

        ws2.Range("G4").Value = ws1.Range("M" & i).Value

        ws2.Range("G5").Value = ws1.Range("N" & i).Value

        ws2.Range("J3").Value = ws1.Range("O" & i).Value

        ws2.Range("J6").Value = ws1.Range("P" & i).Value

        ws2.Range("C9:E9").Value = ws1.Range("Q" & i, "S" & i).Value

        ws2.Range("C10:E10").Value = ws1.Range("T" & i, "V" & i).Value

        ws2.Range("C11:E11").Value = ws1.Range("W" & i, "Y" & i).Value

        ws2.Range("C12:E12").Value = ws1.Range("Z" & i, "AB" & i).Value

        ws2.Range("C13:E13").Value = ws1.Range("AC" & i, "AE" & i).Value

        ws2.Range("C14:E14").Value = ws1.Range("AF" & i, "AH" & i).Value

        ws2.Range("C15:E15").Value = ws1.Range("AI" & i, "AK" & i).Value

        ws2.Range("C16:E16").Value = ws1.Range("AL" & i, "AN" & i).Value


        ws1.Range("AO" & i).Value = ws2.Range("M4").Value

        Application.StatusBar = "Current iteration: " & (i - 1) & "/" & iteration
    Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True

End Sub

The reason I don't just do the calculation in the database worksheet is that there is about 100+ calculations that happen before the final results and the calculations are complex.

The calculation happens almost instantly, it is the copying of the data back and forth that I believe is slowing the whole thing down.

Is there a way to make this more efficient to the point it would only take around 20-30 minutes?


Excel is not a database

I cannot stress this strongly enough. Excel has many excellent uses, but please don't ever get in the habit of thinking that it is a viable alternative to a proper Database.

Never assume that you know where the performance bottleneck is

If you could accurately forecast where a performance bottleneck would be, then you wouldn't have an unbearably slow Macro in the first place.

Rule #1 of performance increases is to benchmark everything, because it will never be where you thought it would be.

Poor man's VBA benchmarking (only accurate to the nearest 1/100th of a second):

Public Sub SplitTimer(ByVal printMessage As String, ByRef oldTimer As Double)
    '/ prints message and time diff between current timer and previous timer
    '/ then updates previous timer with current timer

    Dim currentTimer As Double
    currentTimer = Timer()

    Debug.Print printMessage & " - " & (currentTimer - oldTimer) & " s"

    oldTimer = currentTimer

End Sub

Then, in your Macros:

    Dim timerStore As Double
    timerStore = Timer()

    ws2.Range("B3").Value = ws1.Range("D" & i).Value
    SplitTimer "B3", timerStore

    ws2.Range("B4").Value = ws1.Range("E" & i).Value
    SplitTimer "B4", timerStore

    ws2.Range("B5").Value = ws1.Range("F" & i).Value
    SplitTimer "B5", timerStore

    ws2.Range("B6").Value = ws1.Range("G" & i).Value
    SplitTimer "B6", timerStore

And so on. You'll then get a list of how long each section of your code took to execute. In general, there will be one section that's responsible for ~98% of the runtime:

'/ (hypothetical output)
B3 - 1.40625 s
B4 - 0 s
B5 - 0 s
B6 - 0.041796875 s

Take that operation, split it into smaller pieces, benchmark. Repeat until you've found the source of your slow runtime. Then you can experiment yourself, or take that very specific opeation to SO for performance ideas.

In your specific case, I have a hunch.

Copy/Pasting actually doesn't take a lot of time (per operation). 20 operations in 2 minutes, I'd expect it to be less than 1% of runtime. What takes time is all the Events that trigger when you change a worksheet.

In particular, every calculation is going to re-calculate every time you paste a new value in.

Try this:

Application.Calculation = xlCalculationManual

For i = 4 To selection

    '/ Paste operations

    '/ Paste operations

    '/ Paste operations

    Application.Calculate '/ we only calculate once per iteration, when everything's set up and ready.

    ws1.Range("AO" & i).Value = ws2.Range("M4").Value

Next i

And see if it makes a noticeable difference to your performance.

  • 3
    \$\begingroup\$ And don't forget to add Application.Calculation = xlCalculationAutomatic at the end to turn it back on. \$\endgroup\$ – FreeMan Aug 8 '16 at 20:56

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.