How to speed up this loop??

[FredMFoley]

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

[Qroozn]

When you perform this macro does the screen flash in front of you as it makes the changes?

[Damon Ostrander]

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

[FredMFoley]

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

[Colo]

Hi, Another way...

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

[Nimrod]

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.

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 ]

[FredMFoley]

Thanks for all the help.
It'll take me quite a while to absorb all the feedback.
Fred

[FredMFoley]

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 ]