Faster For Next Loop 3

[PWD]

Good afternoon. I have inherited a task that gets data from our customer, sorted in their preferred order. Basically we have to run down Column "T" and look for occurrences on any of the 6,000 lines in Columns "K" to "S". If it is found in any of these columns (it will only appear once in each row) then add the values from that Row, Column "U" and the put that value in Column "V".

So I have to go through each of the 6,000 rows for the value of "T" & look for it in any of the 6,000 rows.

Basically it is a horrible nested loop of 6,000 x 6,000.

Any suggestions of how I can stop this taking 10+ minutes to run?
Bear in mind I can't re-order the data.

Many thanks,
D€$

 

[fredericofonseca]

regarding sorting --- you can always add a new column populated with a sequence number, sort the data to meet your needs, do all your calculations, and then resort data based on the sequence column you added - then delete that column.


With regards to the loop and calculation - post sample data here, enough to see what you are after, and it will be easier to help you

Regards

Frederico Fonseca
SysSoft Integrated Ltd

http://www.syssoft-int.com

FAQ219-2884
FAQ181-2886

 

[Gavona]

Maybe first use Find to build an array of cells with a match. Build a loop around this:

result(0)=activesheet.cells(1,1)
i=1
result(i) = Columns("K:S").Find( _
    What:="t", _
    After:=result(i - 1), _
    LookIn:=xlFormulas, _
    LookAt:=xlPart, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)

Gavin

 

[PWD]

Good morning; over the weekend I had thought of some sort of 'Find', but wasn't sure about how to handle when the 'Find' doesn't find anymore. Here is the basis of the code that I've inherited:-

For i = 2 To LastRow

    If Range("I" & i).Value = 1 And Range("Z" & i).Value = 0 Then

        k = 0
        For j = 2 To LastRow 'Go through all the rows

          If Range("I" & j).Value <> 1 And (Range("K" & j) = Range("T" & i) _
          Or lev1 = Range("T" & i) _
          Or lev2 = Range("T" & i) _
          Or lev3 = Range("T" & i) _
          Or Range("O" & j) = Range("T" & i) _
          Or Range("P" & j) = Range("T" & i) _
          Or Range("Q" & j) = Range("T" & i) _
          Or Range("R" & j) = Range("T" & i) _
          Or Range("S" & j) = Range("T" & i)) Then
            k = k + Range("U" & j).Value
          End If
        Next 'For j = 2 To LastRow        
        
        Range("V" & i).Value = k
        
    End If 'If Range("I" & i).Value = 1 And Range("Z" & i).Value = 0 Then

(The 'lev1' 'lev2' & 'lev3' are either set to ranges or to "", depending on other factors.

        If Range("AG" & j) = 1 Then ' "M" = Level 2
            lev1 = "FF00"
            If Range("M" & j) = "FF00" _
            Or Range("M" & j) = "ET00" _
            Or Range("M" & j) = "SCBX" _
            Or Range("M" & j) = "FC00" _
            Or Range("M" & j) = "PH00" Then
              lev2 = ""
            Else
              lev2 = Range("M" & j)
            End If
            
            If Range("N" & j) = "FF3" _
            Or Range("N" & j) = "FC3" _
            Or Range("N" & j) = "PH2" Then
              lev3 = ""
            Else
              lev3 = Range("N" & j)
            End If
            
        Else 'if not business finance
            lev1 = Range("L" & j)
            lev2 = Range("M" & j)
            lev3 = Range("N" & j)
        
        End If 'If Range("AG" & j) = 1 Then

)

So basically it's looking to find the value of T & i in ANY of all the rows, PROVIDED that other columns in row i don't contain certain values. (BTW, on the train home on Friday, I did think of adding a new column so I could re-order then revert to the original order - but I'm not sure if that would actually be of much assisatance if I go down the 'Find' route.)

So, as far as I see it now; I could carry out a 'Find', THEN do the filtering to decide whether or not to add the value from column U. At this stage I'm only thinking about analysing one line 'found' at a time (just to keep my head clear) but I'm aware that I should be able to do this whilst running through the array results.

Many thanks,
D€$

 

[SkipVought]

when the 'Find' doesn't find anymore.

HUH???

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[PWD]

Hi Skip. I got confused with something else I had done when the 'Find' didn't find anything & I was thinking about error handling.

However, I am guaranteed to find the value of "T" & i because it is the rightmost value of Columns "K" & i to "S" & i. Which then left me with the problem of how to stop my 'Find' loop. Now here is my clunky, 'Select'y & 'Activate'y code which will probably still take over 5 minutes to run through 6,000 lines. I think I'm on the right lines but would welcome advice on how to speed it up.

    EndRow = Range("A65535").End(xlUp).Row
    
    Columns("K:S").Select
    
''    For i = 2 To EndRow
    For i = 2 To 500 'For a test
    k = 0
    
    MyFind = Range("T" & i)

    Selection.Find(What:=MyFind, After:=Range("K1"), LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
        
        rowfound = ActiveCell.Row
        Firstrow = rowfound
''        MsgBox rowfound

            If Range("I" & ActiveCell.Row) <> "1" Then 'Don't count summaries
            k = k + Range("U" & rowfound).Value
            End If
        
        Do
            Selection.FindNext(After:=ActiveCell).Activate
            
            If ActiveCell.Row > Firstrow Then
            rowfound = ActiveCell.Row
            
            If Range("I" & ActiveCell.Row) <> "1" Then 'Don't count summaries
            k = k + Range("U" & rowfound).Value
            End If
            
''                MsgBox rowfound
            Else: Exit Do
            End If
        Loop
        
        Range("W" & i) = k
        
''        MsgBox "Total " & k
        
Next i

Many thanks,
D€$

 

[SkipVought]

Don't know if this will run any faster, but...

Sub test()
    Dim rFound As Range, Firstrow As Long, EndRow As Long, i As Long, k As Long
'[b]use cells.rows.count rather than a hard row count value[/b]
    EndRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    
    
''    For i = 2 To EndRow
    For i = 2 To 500 'For a test
        k = 0
'[b]set a range object rather than Select[/b]
'[b]you do not need to assign a variable for a single use: Range("T" & i)[/b]
        Set rFound = Columns("K:S").Find( _
            what:=Range("T" & i), _
            After:=Range("K1"), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False, _
            SearchFormat:=False)
'[b]test the range object for existance[/b]
        If Not rFound Is Nothing Then
        
            Firstrow = rFound.Row
    ''        MsgBox rowfound
    
                If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
                    k = k + Cells(rFound.Row, "U").Value
                End If
            
            Do
                Set rFound = Columns("K:S").FindNext(After:=rFound)
                
                If Not rFound Is Nothing Then
                
                    If rFound.Row > Firstrow Then
                    
                        If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
                            k = k + Cells(rFound.Row, "U").Value
                        End If
                    
        ''                MsgBox rowfound
                    Else
                        Exit Do
                    End If
                End If
            Loop
            
            Range("W" & i).Value = k
            
    ''        MsgBox "Total " & k
        End If
        
    Next i
    Set rFound = Nothing
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[PWD]

Thanks Skip. I'll give this a go later today but just got to get back to some routine stuff first.

Many thanks,
D€$

 

[PWD]

Well, just a shade under 7 minutes & 30 seconds. Beats the 20 minutes my colleague says that the loop within a loop used to take, so thanks. I'll take it from here.

Many thanks,
D€$

 

[zelgar]

Is there a reason why you don't use a basic IF and OR command in the cells in Column V?

=if(OR(K2=T,L2=T,M2=T,N2=T,O2=T,P2=T,Q2=T,R2=T,S2=T),U2,)

Where the value of T is named? Otherwise change T to some value?

 

[zelgar]

Alternately, if you can use a combination of the MATCH command and a small macro like the following:

In Row 6001 use the MATCH Command in Cells L through S

=MATCH(T,L2:L6000,0)

and the MACRO looking like the following:

Sub a()
'
' a Macro
'
r = 6001
For i = 1 To 9
    If IsError(Range((Chr$(74 + i)) & r).Value) Then
    Else
        Range("U" & Range((Chr$(74 + i)) & r)) = Range("V" & Range((Chr$(74 + i)) & r))
    End If
Next i

'
    Range("H16").Select
End Sub

 

[N1GHTEYES]

Am I missing something here? If I understand your original problem statement correctly then:

You have a range, say K1:S6000, containing some data (lets call this range "data").
You have another set of values in column T from rows 1 to 6000.
There are also some values in range U1:U6000 (lets call this range "U").

You want to check the value in the cell at column T, row n (for n = 1 to 6000) and compare this to every value in data. Whenever there is a match, you want to note the value in U on the same row as the match in data. You want to add these U values (where there is a match between the T column cell and the whole of data) and put the sum in column V row n.

If that does represent your problem then why not simply use an array formula in the V column?

With the problem as defined above, the following formula works:
in cell V1 put {=SUM(IF(T1=data,U))}.

Put this in cell V1, then set calculation to manual and copy this down to all 6000 cells. Then hit F9 to calculate.

I tested this using random data (and an appropriate tolerance rather than an equality test) and it took ~2mins to complete.

Tony

 

[strongm]

>an array formula

Hurrah! I was looking at putting an array formula together to solve this, but couldn't formulate a correct version (I was trying to be too complicated). Star to you

 

[zelgar]

Looking at all of the previous posts, it looks like the OP is wanting to see for each row if the value of col T is in cols K through S and if so, put the value of col U in col V.

My original code was slighly in error as I thought the OP was looking for a single value of T in all of the data in cols K through S and the 2nd example with the MATCH and macro are also in error.

Using the following simple code in col V and using a sum at the bottom of the data in col V would be easier than the macro:
for Cell V2

=if(OR(K2=T2,L2=T2,M2=T2,N2=T2,O2=T2,P2=T2,Q2=T2,R2=T2,S2=T2),U2,),)

OR

=IF(ISERROR(LOOKUP(T2,K2:S2),0)>0,U2,)

copy and paste for all rows of data
at the end of the rows add

=sum(V2:V6000)

 

[N1GHTEYES]

Actually Zelgar, I think you were right first time - the OP does seem to be looking through the whole of his data in columns K to S to check for comparisons with EVERY value in T. So I don't think the line-by-line approach works.

Thanks for the shiny strongm. A star from the master - I shall treasure it!

Tony

 

[strongm]

>if so, put the value of col U in col V

Nope, sadly not.

 

[zelgar]

Okay....

I don't know if there's any easier way to accomplish everything, but this code will check everything in a row for cols K through S to see if there is any match for everything in Col T and if so, give the result of Col U of the current row. For Cell V2:

=IF(AND(ISERROR(MATCH(K2,T$2:T$14,0)),ISERROR(MATCH(L2,T$2:T$6000,0)),ISERROR(MATCH(M2,T$2:T$6000,0)),ISERROR(MATCH(N2,T$2:T$6000,0)),ISERROR(MATCH(O2,T$2:T$6000,0)),ISERROR(MATCH(P2,T$2:T$6000,0)),ISERROR(MATCH(Q2,T$2:T$6000,0)),ISERROR(MATCH(R2,T$2:T$6000,0)),ISERROR(MATCH(S2,T$2:T$6000,0))),0,U2)

Copy & paste for all other cells in Col V

 

[N1GHTEYES]

I think your code does it the wrong way round with respect to the OP's request.

As far as I can see, your entryu in column V is dependent on whether the values in columns K to S of row n match any T. What he wants is whether the value on THIS row of T matches ANY value in columns S to K in all the rows.

That is what my formula does.

By the way, I modded the data to be able to use a simple equality check (as previously posted) rather than having to do a toleranced check, and it runs on the 6000 rows in ~ 90s.

So I think what I proposed is the OP's best solution.

Tony

 

[PWD]

Here's a look at the final version - based on Skip's code:-

For i = 2 To EndRow - 3'Ignore final 3 rows
     
' If not aggregate: headcount = column v
If Range("I" & i).Value <> 1 Then 'Not an Aggregate
        Range("V" & i).Value = Range("U" & i).Value 'Put Headcount in "V"
        'then go down to next line
      
''        ' If aggregate & not GPS:
    ElseIf Range("I" & i).Value = 1 And Range("Z" & i).Value = 0 Then
    'Exclude F(ood) & PO from counting
     

 k = 0 'set a range object rather than Select
 'you do not need to assign a variable for a single use: Range("T" & i)
    Set rFound = Columns("K:S").Find( _
    What:=Range("T" & i), _
    After:=Range("K1"), _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    'test the range object for existance
    If Not rFound Is Nothing Then
    Firstrow = rFound.Row
''''
''''''        If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
''''
'If business finance
        If Cells(rFound.Row, "AG") = 1 Then ' "M" = Level 2
            lev1 = "FF00"

            If Cells(rFound.Row, "M") = "FF00" _
            Or Cells(rFound.Row, "M") = "ET00" _
            Or Cells(rFound.Row, "M") = "SCBX" _
            Or Cells(rFound.Row, "M") = "FC00" _
            Or Cells(rFound.Row, "M") = "PH00" Then
              lev2 = ""
            Else
              lev2 = Cells(rFound.Row, "M")
            End If 'All of the above!!

            If Cells(rFound.Row, "N") = "FF3" _
            Or Cells(rFound.Row, "N") = "FC3" _
            Or Cells(rFound.Row, "N") = "PH2" Then
              lev3 = ""
            Else
              lev3 = Cells(rFound.Row, "N")
            End If 'All of the aboove!!

        Else 'if not business finance
            lev1 = Cells(rFound.Row, "L")
            lev2 = Cells(rFound.Row, "M")
            lev3 = Cells(rFound.Row, "N")

        End If 'If Cells(rFound.Row, "AG") = 1 Then ' "M" = Level 2
        
        'If not aggregate add up head count for any level into current rows team
        '"I" = "Aggregate Code"
        '"T" = "Survey Print Code" - last column level
        '"O" = "Level 4"
        '"P" = "Level 5"
        '"Q" = "Level 6"
        '"R" = "Level 7"
        '"S" = "Level 8"
    If (Cells(rFound.Row, "I").Value <> 1 And (Cells(rFound.Row, "K") = Range("T" & i)) _
    Or lev1 = Range("T" & i) _
    Or lev2 = Range("T" & i) _
    Or lev3 = Range("T" & i) _
    Or Cells(rFound.Row, "O") = Range("T" & i) _
    Or Cells(rFound.Row, "P") = Range("T" & i) _
    Or Cells(rFound.Row, "Q") = Range("T" & i) _
    Or Cells(rFound.Row, "R") = Range("T" & i) _
    Or Cells(rFound.Row, "S") = Range("T" & i)) Then
        
''        If Cells(rFound.Row, "U") <> "" Then
        If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
        
        k = k + Cells(rFound.Row, "U").Value
        End If 'If Cells(rFound.Row, "U") <> "" Then
        
    End If
        
        

''        If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries

''''        k = k + Cells(rFound.Row, "U").Value
        


        'Do a "Find Next" to get ALL of the rest of the required values
           Do
                 Set rFound = Columns("K:S").FindNext(After:=rFound)
                 If Not rFound Is Nothing Then
                   If rFound.Row > Firstrow Then

'If business finance
        If Cells(rFound.Row, "AG") = 1 Then ' "M" = Level 2
            lev1 = "FF00"

            If Cells(rFound.Row, "M") = "FF00" _
            Or Cells(rFound.Row, "M") = "ET00" _
            Or Cells(rFound.Row, "M") = "SCBX" _
            Or Cells(rFound.Row, "M") = "FC00" _
            Or Cells(rFound.Row, "M") = "PH00" Then
              lev2 = ""
            Else
              lev2 = Cells(rFound.Row, "M")
            End If 'All of the above!!

            If Cells(rFound.Row, "N") = "FF3" _
            Or Cells(rFound.Row, "N") = "FC3" _
            Or Cells(rFound.Row, "N") = "PH2" Then
              lev3 = ""
            Else
              lev3 = Cells(rFound.Row, "N")
            End If 'All of the aboove!!

        Else 'if not business finance
            lev1 = Cells(rFound.Row, "L")
            lev2 = Cells(rFound.Row, "M")
            lev3 = Cells(rFound.Row, "N")

        End If 'If Cells(rFound.Row, "AG") = 1 Then ' "M" = Level 2
        
        'If not aggregate add up head count for any level into current rows team
        '"I" = "Aggregate Code"
        '"T" = "Survey Print Code" - last column level
        '"O" = "Level 4"
        '"P" = "Level 5"
        '"Q" = "Level 6"
        '"R" = "Level 7"
        '"S" = "Level 8"
    If (Cells(rFound.Row, "I").Value <> 1 And (Cells(rFound.Row, "K") = Range("T" & i)) _
    Or lev1 = Range("T" & i) _
    Or lev2 = Range("T" & i) _
    Or lev3 = Range("T" & i) _
    Or Cells(rFound.Row, "O") = Range("T" & i) _
    Or Cells(rFound.Row, "P") = Range("T" & i) _
    Or Cells(rFound.Row, "Q") = Range("T" & i) _
    Or Cells(rFound.Row, "R") = Range("T" & i) _
    Or Cells(rFound.Row, "S") = Range("T" & i)) Then
        
''        If Cells(rFound.Row, "U") <> "" Then
        If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
        
        k = k + Cells(rFound.Row, "U").Value
        End If 'If Cells(rFound.Row, "U") <> "" Then
        
    End If

                       If Cells(rFound.Row, "I").Value <> "1" Then 'Don't count summaries
                       k = k + Cells(rFound.Row, "U").Value
                       End If
                   Else
                   Exit Do
                   End If 'If rFound.Row > Firstrow Then
                 End If 'If Not rFound Is Nothing Then
           Loop
      Range("V" & i).Value = k
      
End If 'If Not rFound Is Nothing Then

End If 'If Range("I" & i).Value = 1 And Range("Z" & i).Value = 0 Then
      
Next i
Set rFound = Nothing

It's also fairly complicated in asmuchas the value from Column T can occur any number of times on the sheet. There are also other criteria as whether or not to count the value of Column U so I decided to apply those after each successful 'Find'. (I hope I have cut & pasted this code in here OK)

Thank you all for your input.

Many thanks,
D€$

 

[N1GHTEYES]

PWD - as a matter of interest, does that give the same results as my formula? If so, how long do they both take?

Tony