I need a Faster loop

[Hal75]

Dear All,

I am new to Excel VBA. I have two sheets in the same workbook, Sheet1 & Production. In "Sheet1" I have two columns A & B with date and well names. I need to loop through these rows and compare to production sheet. If well name and date are matched then get production figure. I managed to get it working but my real sheet has over 23,000 rows and over 200 columns on both sheets so I need a faster and more efficient way of doing this. my current code looks like this:

Private Sub CommandButton1_Click()

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim iRow As Long
Dim jRow As Long
Dim kCol As Long

'Find the last non-blank row in Sheet1
iRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Row

'Find the last non-blank row in Production sheet
jRow = Worksheets("Production").Range("A" & Rows.Count).End(xlUp).Offset(1).Row

'Find the last non-blank column in Production sheet
kCol = Worksheets("Production").Cells(1, Columns.Count).End(xlToLeft).Column



For i = 2 To iRow
For j = 2 To jRow
For k = 2 To kCol


If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Production").Cells(j, 1) Then

If Worksheets("Sheet1").Cells(i, 1) = Worksheets("Production").Cells(1, k) Then

Worksheets("Sheet1").Cells(i, 3) = Worksheets("Production").Cells(j, k)

End If
End If

Next k
Next j
Next i


End Sub







my "Sheet1" looks like this"

Name	Date	Production
Well A	01/01/2017
Well B	01/01/2017
Well C	01/01/2017
Well A	02/01/2017
Well B	02/01/2017
Well C	02/01/2017
Well A	03/01/2017
Well B	03/01/2017
Well C	03/01/2017

<tbody>
</tbody><colgroup><col><col><col></colgroup>

my "Production sheet looks like this:

Date	Well A	Well B	Well C
05/02/2015	1	10	100
06/02/2015	2	20	200
07/02/2015	3	30	300
08/02/2015	4	40	400
09/02/2015	5	50	500
10/02/2015	6	60	600
11/02/2015	7	70	700
12/02/2015	8	80	800
13/02/2015	9	90	900
14/02/2015	10	100	1000
15/02/2015	11	110	1100
01/01/2017	12	120	1200
02/01/2017	13	130	1300
03/01/2017	14	140	1400

<tbody>
</tbody><colgroup><col><col span="3"></colgroup>

For short number of rows and columns the code works well. However it takes forever when I ran it with real data with over 20,000 rows. Please help me to optimize the loop so it can runs faster.


Regards,

 

[jkpieterse]

This is easily done using get and transform and the unpivot functionality.

 

[Hal75]

This is easily done using get and transform and the unpivot functionality.

Thanks but I have no clue with get and transform. An example would be useful.

Idealy I would like to do it using macro but I am open for any good solution. Thanks

 

[Norie]

Couldn't you just use a formula?

Put this in C2 on Sheet1 and copy down.

=INDEX(Production!$B$2:$D$15,MATCH(B2,Production!$A$2:$A$15,0),MATCH(A2, Production!$B$1:$D$1,0))

 

[mikerickson]

I would re-arrange the loops and the tests so that failed tests eliminate some of the loops.
The OP code

For i = 2 To iRow
    For j = 2 To jRow
        For k = 2 To kCol
            If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Production").Cells(j, 1) Then
                If Worksheets("Sheet1").Cells(i, 1) = Worksheets("Production").Cells(1, k) Then
                    Worksheets("Sheet1").Cells(i, 3) = Worksheets("Production").Cells(j, k)
                End If
            End If
        Next k
    Next j
Next i

tests If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Production").Cells(j, 1) kCol times for every i,j, even if the i/j condition fails.

But if that test is moved outside the For K loop, if it fails, it moves straight to the next i, j

For i = 2 To iRow
    For j = 2 To jRow
        If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Production").Cells(j, 1) Then
            For k = 2 To kCol
                If Worksheets("Sheet1").Cells(i, 1) = Worksheets("Production").Cells(1, k) Then
                    Worksheets("Sheet1").Cells(i, 3) = Worksheets("Production").Cells(j, k)
                End If
            Next k
        End If
    Next j
Next i

 

[Rick Rothstein]

I think Norie's suggestion in Message #4 would be the best approach; however, if you need this to be done using VB code, then we can use Norie's formula as a basis to reduce the number of loops down to just one...

[table="width: 500"]
[tr]
	[td]Private Sub CommandButton1_Click()
  Dim R As Long, WSs As Worksheet, WSp As Worksheet
  Set WSs = Sheets("Sheet1")
  Set WSp = Sheets("Production")
  With Application
    .ScreenUpdating = False
    For R = 2 To WSs.Cells(Rows.Count, "A").End(xlUp).Row
      WSs.Cells(R, "C").Value = .Index(WSp.Cells, .Match(WSs.Cells(R, "B").Value2, WSp.Columns("A"), 0), .Match(WSs.Cells(R, "A").Value, WSp.Rows(1), 0))
    Next
    .ScreenUpdating = True
  End With
End Sub[/td]
[/tr]
[/table]

 

[MARK858]

Would it be faster to apply the formula to the whole range in one go and change to values rather than use the loop (not home to test)?

 

[Norie]

I'm pretty sure the formula approach, applied either manually or with code, would be the best option.

It's not a complicated formula after all.

 

[offthelip]

looking through this thread nobody has addressed the real problem of how to write faster loops in VBA. When trying to speed up code it is usually best to try and address the item that takes the most time. The most common cause of "slow" VBa is multiple accesses to the worksheet. The way to avoid this is to load all the data from a worksheet into a variant array and then operate on the variant array and then write it back to the worksheet. The two subroutines below take about the same amount of time on my machine ( about 2.2 seconds) however the one using variant arrays does exactly the same thing 500 times. i.e it is 500 times faster!!! I think everybody will agree that is a significant improvement.

Sub slow()
tt = Timer()
'initialise
 For j = 1 To 10
  Cells(j, 1) = 0
 Next j
For i = 1 To 1000
 For j = 1 To 10
  Cells(j, 1) = Cells(j, 1) + 1
 Next j
Next i
MsgBox (Timer() - tt)


End Sub


Sub fast()
tt = Timer()
For k = 1 To 500
'initialise
 For j = 1 To 10
  Cells(j, 1) = 0
 Next j




inarr = Range(Cells(1, 1), Cells(10, 1))
For i = 1 To 1000
 For j = 1 To 10
  inarr(j, 1) = inarr(j, 1) + 1
 Next j
Next i
Range(Cells(1, 1), Cells(10, 1)) = inarr
Next k


MsgBox (Timer() - tt)


End Sub

The way I would modify the Op to do this is below ( Untested!!). I would expect this to be at least 500 times faster as well

Private Sub CommandButton1_Click()


Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim iRow As Long
Dim jRow As Long
Dim kCol As Long


'Find the last non-blank row in Sheet1
iRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Row


'Find the last non-blank row in Production sheet
jRow = Worksheets("Production").Range("A" & Rows.Count).End(xlUp).Offset(1).Row


'Find the last non-blank column in Production sheet
kCol = Worksheets("Production").Cells(1, Columns.Count).End(xlToLeft).Column
' load the worksheet data into varaint arays
With Worksheets("sheet1")
sht1arr = Range(.Cells(1, 1), .Cells(iRow, 3))
End With
With Worksheets("Production")
prodarr = Range(.Cells(1, 1), .Cells(jRow, kCol))
For i = 2 To iRow
For j = 2 To jRow
For k = 2 To kCol




If sht1arr(i, 2) = prodarr(j, 1) Then


If sht1arr(i, 1) = prodarr(1, k) Then


sht1arr(i, 3) = prodarr(j, k)


End If
End If


Next k
Next j
Next i
' write the variant arrays back to the worksheet
With Worksheets("sheet1")
 Range(.Cells(1, 1), .Cells(iRow, 3)) = sht1arr
End With




End Sub

 

[offthelip]

I realised I have missed out an "end with"
code should be:

With Worksheets("Production")
prodarr = Range(.Cells(1, 1), .Cells(jRow, kCol))
End With