Thanks Thanks:  0
Likes Likes:  0
Results 1 to 8 of 8

Thread: How to speed up this loop??

  1. #1
    Board Regular
    Join Date
    Mar 2002
    Location
    Tasmania
    Posts
    58
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  2. #2
    Board Regular
    Join Date
    Mar 2002
    Location
    Sydney/Brisbane , Australia
    Posts
    542
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

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

  3. #3
    MrExcel MVP Damon Ostrander's Avatar
    Join Date
    Feb 2002
    Location
    Denver, Colorado USA
    Posts
    4,239
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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
    Keep Excelling.

    Damon

    VBAexpert Excel Consulting
    LinkedIn Profile http://www.linkedin.com/pub/damon-ostrander/7/79/a93
    AllExperts Profile http://www.allexperts.com/ep/1059-30...-Ostrander.htm

  4. #4
    Board Regular
    Join Date
    Mar 2002
    Location
    Tasmania
    Posts
    58
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  5. #5
    MrExcel MVP
    Colo's Avatar
    Join Date
    Mar 2002
    Location
    Kobe, Japan
    Posts
    1,456
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    2 Thread(s)

    Default

    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

    Hope this helps + pen pineapple apple pen!

    Masaru Kaji aka Colo - cellmasters.net

  6. #6
    MrExcel MVP
    Join Date
    Apr 2002
    Location
    Vancouver BC , Canada
    Posts
    6,259
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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 ]

  7. #7
    Board Regular
    Join Date
    Mar 2002
    Location
    Tasmania
    Posts
    58
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

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

  8. #8
    Board Regular
    Join Date
    Mar 2002
    Location
    Tasmania
    Posts
    58
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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 ]

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •