How to speed up this loop??

FredMFoley

Board Regular
Joined
Mar 18, 2002
Messages
58
I would appreciate any help to speed this sub up please as my knowledge of VBA is still very limited.

Column A on Sheet1 contains about 1500 unique values (no blanks).
Column A on Sheet2 contains about 1000 of the Sheet1 values (no blanks).
Neither column is sorted and both sheets have data in other columns.

My sub finds the matching values in the two A Columns, then transfers data IN OTHER COLUMNS from one sheet to the other, and puts it in the matching row.

While I'm pleased that it works, it is frustratingly slow (about 80sec), and I'm sure there would be much faster ways to do it.



Sub CompareAndTransfer()
Dim i%, j%, OldCodes%, NewCodes%, NewColumn%, NewSheet$, TextFile$, Codes$

For i = 1 To OldCodes '2 allows for heading
For j = 1 To NewCodes
If Sheets("Codes").Cells(i, 1) = Sheets(TextFile).Cells(j, 1) _
Then Sheets("Codes").Cells(i, 4) = Sheets(TextFile).Cells(j, 6) _
: j = NewCodes 'jump out when found (to save time)
Next j
Next i
End Sub

Thank You
Fred
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
When you perform this macro does the screen flash in front of you as it makes the changes?
 
Upvote 0
Hi Fred,

Its already reasonably efficient as you have it. These changes might help a bit by getting as many operations out of the inner loop as possible:

Sub CompareAndTransfer()

Dim i%, j%, OldCodes%, NewCodes%, NewColumn%, NewSheet$, TextFile$, Codes$
Dim Cell1 As Range
Dim Cell4 As Range
Dim WST As Worksheet

' don't forget to set TextFile$ and NewSheet$, etc.

Set WST = Worksheets(TextFile)

With Sheets("Codes")
For i = 1 To OldCodes '2 allows for heading
Set Cell1 = .Cells(i, 1)
Set Cell4 = .Cells(i, 4)
For j = 1 To NewCodes
If Cell1.Value = WST.Cells(j, 1) Then
Cell2.Value = WST.Cells(j, 6)
Exit For 'jump out when found (to save time)
End If
Next j
Next i

End With
End Sub
 
Upvote 0
Thanks for the reply.

I have tried it with and without

Application.ScreenUpdating = False
Sub
End Sub
Application.ScreenUpdating = True

and it makes very little difference
 
Upvote 0
Hi, Another way...

<pre>
Sub TryThis()
Dim rngList1 As Range, rngList2 As Range
Dim strBuf() As String, rngTmp As Range, strNewBuf() As String
Dim ret, LngN As Long, lngCnt As Long, strTmp As String
'Assume
Dim TextFile As String
TextFile = "TextFile"

With Sheets("Codes")
Set rngList1 = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
With Sheets(TextFile)
Set rngList2 = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With

For Each rngTmp In rngList1
ret = Application.Match(rngTmp.Value, rngList2, 0)
If Not IsError(ret) Then
strTmp = Sheets(TextFile).Cells(ret, 6).Value
Else
strTmp = ""
End If
LngN = LngN + 1
ReDim Preserve strBuf(1 To LngN)
strBuf(LngN) = strTmp
Next

ReDim strNewBuf(1 To LngN, 1 To 1)
For lngCnt = 1 To LngN
strNewBuf(lngCnt, 1) = strBuf(lngCnt)
Next
With Sheets("Codes")
.Columns(4).ClearContents
.Cells(1, 4).Resize(LngN).Value = strNewBuf()
End With
End Sub
</pre>
 
Upvote 0
Instead of going through the Target list every time ie 1500x1000 go directly to the Target Row with the find command. Here's some code to give you a general idea. You will need to modify the sheet name etc. Best look in your VB help for a total picture.

Code:
Public Sub FindAndReplace()

For i = 1 To OldCodes '2 allows for heading
ValueToFind = Sheets("Codes").Cells(i, 1)

With Worksheets(1).Range("a1:a1000")
    Set c = .Finds(ValueToFind,LookIn:=xlValues)
   TargRow = c.Row
End With
 Sheets("Codes").Cells(i, 4) = Sheets(TextFile).Cells(TargRow, 6)
Next 
End Sub

This method will cut your loops down from 1000x1500 to just 1000 !!!
This message was edited by Nimrod on 2002-05-09 20:33
This message was edited by nimrod on 2002-05-09 20:58
 
Upvote 0
Thanks Nimrod
When I use your code this line

Set c = .Finds(ValueToFind, LookIn:=xlValues)

Causes this error:
Object doesn't support this property or method

Can you tell me what is wrong here?
---------
I found the mistake - eventually! - Finds should have been Find.
After making minor changes this method has cut the time down to about 3 or 4 seconds!!
Thanks again Nimrod


Damon's solution cut the time down from 80 sec to about 30sec, and I haven't tackled Colo's yet - It looks a bit daunting to me.

Thanks for all the help.
This message was edited by FredMFoley on 2002-05-11 04:34
 
Upvote 0

Forum statistics

Threads
1,213,522
Messages
6,114,112
Members
448,549
Latest member
brianhfield

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