I need a Faster loop

H

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"
[TABLE="width: 241"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Date[/TD]
[TD]Production[/TD]
[/TR]
[TR]
[TD="align: left"]Well A[/TD]
[TD="align: right"]01/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well B[/TD]
[TD="align: right"]01/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well C[/TD]
[TD="align: right"]01/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well A[/TD]
[TD="align: right"]02/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well B[/TD]
[TD="align: right"]02/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well C[/TD]
[TD="align: right"]02/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well A[/TD]
[TD="align: right"]03/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well B[/TD]
[TD="align: right"]03/01/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: left"]Well C[/TD]
[TD="align: right"]03/01/2017[/TD]
[TD][/TD]
[/TR]
</tbody><colgroup><col><col><col></colgroup>[/TABLE]



my "Production sheet looks like this:
[TABLE="width: 267"]
<tbody>[TR]
[TD="align: left"] Date [/TD]
[TD="align: left"]Well A[/TD]
[TD="align: left"]Well B[/TD]
[TD="align: left"]Well C[/TD]
[/TR]
[TR]
[TD="align: right"]05/02/2015[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]100[/TD]
[/TR]
[TR]
[TD="align: right"]06/02/2015[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]20[/TD]
[TD="align: right"]200[/TD]
[/TR]
[TR]
[TD="align: right"]07/02/2015[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]30[/TD]
[TD="align: right"]300[/TD]
[/TR]
[TR]
[TD="align: right"]08/02/2015[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]40[/TD]
[TD="align: right"]400[/TD]
[/TR]
[TR]
[TD="align: right"]09/02/2015[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]50[/TD]
[TD="align: right"]500[/TD]
[/TR]
[TR]
[TD="align: right"]10/02/2015[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]60[/TD]
[TD="align: right"]600[/TD]
[/TR]
[TR]
[TD="align: right"]11/02/2015[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]70[/TD]
[TD="align: right"]700[/TD]
[/TR]
[TR]
[TD="align: right"]12/02/2015[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]80[/TD]
[TD="align: right"]800[/TD]
[/TR]
[TR]
[TD="align: right"]13/02/2015[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]90[/TD]
[TD="align: right"]900[/TD]
[/TR]
[TR]
[TD="align: right"]14/02/2015[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]100[/TD]
[TD="align: right"]1000[/TD]
[/TR]
[TR]
[TD="align: right"]15/02/2015[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]110[/TD]
[TD="align: right"]1100[/TD]
[/TR]
[TR]
[TD="align: right"]01/01/2017[/TD]
[TD="align: right"]12[/TD]
[TD="align: right"]120[/TD]
[TD="align: right"]1200[/TD]
[/TR]
[TR]
[TD="align: right"]02/01/2017[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]130[/TD]
[TD="align: right"]1300[/TD]
[/TR]
[TR]
[TD="align: right"]03/01/2017[/TD]
[TD="align: right"]14[/TD]
[TD="align: right"]140[/TD]
[TD="align: right"]1400[/TD]
[/TR]
</tbody><colgroup><col><col span="3"></colgroup>[/TABLE]



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,
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
jkpieterse said:
This is easily done using get and transform and the unpivot functionality.
Click to expand...

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
 
Upvote 0
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))
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0
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:
Upvote 0
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.:)
 
Upvote 0
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:
Upvote 0
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:
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
598
OilEconomist
O
tezza
  • Solved
Autosum specific rows and columns
Replies
2
Views
258
tezza
tezza
O
  • Solved
If I delete row from sheet then decrease amount in other sheet
Replies
4
Views
267
mumps
mumps
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
800
Agnarr
Agnarr
B
  • Question Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
554
B-radK
B

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

Share this page

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
Back
Top