Copying orders and prices into another Excel sheet

Question

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

Answer 1

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):

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.

Answer 2

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.

Answer 3

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?

Answer 4

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%")