4
\$\begingroup\$

I would like to know if the below VBA can be streamlined to process faster, since it takes on average 9hrs to complete a sheet (800 000 lines), and I have quite a few to get through. Running on 3 computers already to get ahead of the work.

Sub Calculate_Sheet()

Dim orderSh As Worksheet
Dim wiroSh As Worksheet
Dim lastRow As Long, r As Long
Dim pctComp As Double
Dim Arr1 As Variant
Dim StartTime As Double
Dim MinutesElapsed As String

StartTime = Timer

With ThisWorkbook
'calculator
  Set orderSh = .Sheets("ORDER")
'price list
  Set wiroSh = .Sheets("WiroA3C100gsmI100gsm116-118pp ")
End With

Arr1 = wiroSh.Range("C1:M800001")
lastRow = wiroSh.Cells(Rows.Count, 3).End(xlUp).Row

For r = 2 To 2


'copy from price list to calculator
  orderSh.Range("F4") = Arr1(r, 1)
  orderSh.Range("F5") = Arr1(r, 2)
  orderSh.Range("F6") = Arr1(r, 3)
  orderSh.Range("F7") = Arr1(r, 4)
  orderSh.Range("F8") = Arr1(r, 5)
  orderSh.Range("F9") = Arr1(r, 6)
  orderSh.Range("F10") = Arr1(r, 7)
  orderSh.Range("F11") = Arr1(r, 8)
  orderSh.Range("F12") = Arr1(r, 9)
  orderSh.Range("F13") = Arr1(r, 10)

'copy result
  wiroSh.Range("m" & r).Value = orderSh.Range("F14")

 Next r

    For r = 3 To 400001

    'copy from price list to calculator
        orderSh.Range("F4") = Arr1(r, 1)

    'copy result
        wiroSh.Range("m" & r).Value = orderSh.Range("F14")

         'display the row and percentage each 1000 rows
        If r Mod 1 = 0 Then
        Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
        End If

     Next r

          For r = 400002 To 400002
          'copy from price list to calculator
              orderSh.Range("F4") = Arr1(r, 1)
              orderSh.Range("F5") = Arr1(r, 2)
              orderSh.Range("F6") = Arr1(r, 3)
              orderSh.Range("F7") = Arr1(r, 4)
              orderSh.Range("F8") = Arr1(r, 5)
              orderSh.Range("F9") = Arr1(r, 6)
              orderSh.Range("F10") = Arr1(r, 7)
              orderSh.Range("F11") = Arr1(r, 8)
              orderSh.Range("F12") = Arr1(r, 9)
              orderSh.Range("F13") = Arr1(r, 10)

        'copy result
              wiroSh.Range("m" & r).Value = orderSh.Range("F14")

     Next r

                For r = 400003 To 800001
                  'copy from price list to calculator
                      orderSh.Range("F4") = Arr1(r, 1)

                  'copy result
                         wiroSh.Range("m" & r).Value = orderSh.Range("F14")


           'display the row and percentage each 1000 rows
  If r Mod 1 = 0 Then
     Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")

  End If
Next r

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub
\$\endgroup\$

migrated from stackoverflow.com May 16 '16 at 10:09

This question came from our site for professional and enthusiast programmers.

  • \$\begingroup\$ You could turn calculation off and calculate when needed, and also transpose the array's, maybe? \$\endgroup\$ – Nathan_Sav May 16 '16 at 10:17
  • \$\begingroup\$ Hi Nathan, I am afraid turning calculations might not work, as what is happening is that the input values from each each line in the "wiro" sheet are put into the "order" sheet, which calculates the total price, and then puts into a price column back in the "wiro" sheet @Nathan_Sav \$\endgroup\$ – Wayne Louwrens May 16 '16 at 10:24
  • \$\begingroup\$ I am liking the transposing idea, I might need some guidance though. Thanks for the suggestion :) \$\endgroup\$ – Wayne Louwrens May 16 '16 at 10:31
  • \$\begingroup\$ Is the calculation a UDF or an excel function in cell f14? Transposing really won't help much , because you only do 2 whole row copies. The rest are a single cell values. \$\endgroup\$ – Gareth May 16 '16 at 10:55
  • 1
    \$\begingroup\$ Welcome to Code Review. Could you give us a better idea of what you are doing and why you are doing it? (See How to Ask.) What does the calculation sheet look like? How much time does it take if you copy the ranges into a blank sheet instead into the calculation sheet? What do you consider to be the inputs and outputs of this business process? Perhaps the copying could be avoided altogether? \$\endgroup\$ – 200_success May 16 '16 at 13:16
3
\$\begingroup\$

There's likely many factors at play here, but here's my two cents:

It looks like you're copying whole cell's onto another sheet for calculation, and again to a results sheet.

What will be happening here is that when copying the values, it will be copying all the information about cells and not just the values. By adding a cell to the watch list you can see just how much information is there that in most cases you don't need (this is just a small section of the entire list): Cell information view example

I would suggest reviewing your copy method to copy only the information you actually need (quite possibly just .Value), this will save both memory and processing.

\$\endgroup\$
2
\$\begingroup\$

1) I would guess that the calculation which finally produces a result in F14 is itself the main cause of the delay. Is there anyway you can make the calculation in Excel itself more efficient?

2) Could you confine recalculation to just the the worksheet (or range) which is actually doing the updated calculation? i.e. set calculation mode to manual and then just recalculate orderSh with

orderSh.Calculate

3) I don't think it will help in your case but you are not turning off screen updating.

Application.Screenupdating = False

may help a little, although given that not much is changing, I don't think this would help a lot.

\$\endgroup\$
2
\$\begingroup\$

You have an update happening to the Application.StatusBar for every row although your comment indicates you intended to update it every 1000 rows? Try changing that and see if you get any speed up from that:

For r = 3 To 400001
    If r Mod 1000 = 0 Then
        Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
    End If
Next r

Otherwise r Mod 1 = 0 gives you the remainder after dividing R by 1, which will always be zero and therefore always trigger the update.

I'd also suggest moving the calculation that's happening in F14 directly into the code; this might be faster than copying all the inputs into a sheet for the calculation and then copying all the results back out again?

\$\endgroup\$
0
\$\begingroup\$

What is in orderSh.Range("F14") that can't be calculated to a variable within vba so you aren't writing to and from the sheet constantly?

Convert whatever that is to a Private Function and pass variables to it ByVal - this will speed up a lot.

In fact, pass it to an array and pass the array

Dim result As Long
Dim smallarr As Variant
    For r = 1 To 10
        smallarr(r) = arr1(2, r)
    Next

result = whatEverf14is(smallarr)

with

Private Function whatEverf14is(ByVal smallarr As Variant) As Long
    'do the F14 stuff here
End Function

You should see incredible improvement with that.

You would end up with something like this

Option Explicit
Public Sub BetterName()
    Dim wiroSh As Worksheet
    Set wiroSh = ThisWorkbook.Sheets("WiroA3C100gsmI100gsm116-118pp ")
    Dim lastRow As Long
    lastRow = wiroSh.Cells(Rows.Count, 3).End(xlUp).Row

    Dim r As Long
    Dim result As Long
    Dim myArray As Variant
    Dim smallArray As Variant

    Dim StartTime As Double
    Dim MinutesElapsed As String

    StartTime = Timer

    myArray = wiroSh.Range("C1:M800001")

    For r = 1 To 10
        smallArray = myArray(2, r)
    Next

    result = whatEverf14is(smallArray)
    wiroSh.Range("m" & r).Value = result


    For r = 3 To 400001
        wiroSh.Range("m" & r).Value = whatEverf14is(myArray(r, 1))
        If r Mod 1 = 0 Then Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
    Next r

    For r = 1 To 10
        smallArray = myArray(40002, r)
    Next
    result = whatEverf14is(smallArray)
    wiroSh.Range("m" & r).Value = result


    For r = 400003 To 800001
        wiroSh.Range("m" & r).Value = whatEverf14is(myArray(r, 1))
        If r Mod 1 = 0 Then Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
    Next r

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Private Function whatEverf14is(ByVal smallArray As Variant) As Long
    'do the F14 stuff here
End Function

How would this if ever not be satisfied?

If r Mod 1 = 0 Then Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
\$\endgroup\$

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