I need a Faster loop

Hal75

New Member
Joined
Dec 31, 2017
Messages
2
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"
NameDateProduction
Well A01/01/2017
Well B01/01/2017
Well C01/01/2017
Well A02/01/2017
Well B02/01/2017
Well C02/01/2017
Well A03/01/2017
Well B03/01/2017
Well C03/01/2017

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



my "Production sheet looks like this:
Date Well AWell BWell C
05/02/2015110100
06/02/2015220200
07/02/2015330300
08/02/2015440400
09/02/2015550500
10/02/2015660600
11/02/2015770700
12/02/2015880800
13/02/2015990900
14/02/2015101001000
15/02/2015111101100
01/01/2017121201200
02/01/2017131301300
03/01/2017141401400

<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,
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

jkpieterse

Well-known Member
Joined
Dec 3, 2007
Messages
1,080
This is easily done using get and transform and the unpivot functionality.
 

Hal75

New Member
Joined
Dec 31, 2017
Messages
2
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

Well-known Member
Joined
Apr 28, 2004
Messages
76,230
Office Version
  1. 365
Platform
  1. Windows
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

MrExcel MVP
Joined
Jan 15, 2007
Messages
23,920

ADVERTISEMENT

I would re-arrange the loops and the tests so that failed tests eliminate some of the loops.
The OP code
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

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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,712
Office Version
  1. 2010
Platform
  1. Windows
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...
Code:
[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]
 
Last edited:

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
13,886
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile

ADVERTISEMENT

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)?
 
Last edited:

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,230
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,666
Office Version
  1. 2010
Platform
  1. Windows
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.
Code:
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
Code:
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
 
Last edited:

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,666
Office Version
  1. 2010
Platform
  1. Windows
I realised I have missed out an "end with"
code should be:

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

Watch MrExcel Video

Forum statistics

Threads
1,123,321
Messages
5,600,948
Members
414,417
Latest member
Nobu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top