Copying orders and prices into another Excel sheet

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


migrated from stackoverflow.comMay 16 '16 at 10:09

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

• You could turn calculation off and calculate when needed, and also transpose the array's, maybe? – Nathan_Sav May 16 '16 at 10:17
• 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 – Wayne Louwrens May 16 '16 at 10:24
• I am liking the transposing idea, I might need some guidance though. Thanks for the suggestion :) – Wayne Louwrens May 16 '16 at 10:31
• 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. – Gareth May 16 '16 at 10:55
• 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? – 200_success May 16 '16 at 13:16

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.

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.

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?

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