Optimizing VBA

[Paleo]

I created this VBA code:

Sub macro1()
     Dim i As Long, Texto As String, j As Long
     For i = 1 To Range("K65536").End(xlUp).Row
         Range("K" & i).Select
         Select Case ActiveCell.Value
             Case 0
                 ActiveCell.Offset(0, 1).Select
                 ActiveCell.Value = "Ok"
             Case Is < 0
                 ActiveCell.Offset(0, 1).Select
                 ActiveCell.Value = "Under"
             Case Else
                 Texto = Range("B" & i).Value & Range("D" & i).Value
                 With Sheets("Class 2")
                     For j = 2 To .Range("A65536").End(xlUp).Row
                         If (.Range("A" & j).Value & .Range("B" & j).Value) = Texto _
 And .Range("D" & j).Value = 0 Then
                                 ActiveCell.Offset(0, 1).Select
                                 ActiveCell.Value = "Above"
                                 Exit For
                         End If
                     Next j
                 End With
         End Select
     Next i
     Range("K1").Select
 End Sub

But its TOO slow. It takes 1 sec per row and as my sheet has 22,000 rows its TOO much.

Can anyone help me to optimize it?

[Jacob Hilderbrand]

The first thing we can do is get rid of the selecting code which should speed it up a bit.

Option Explicit
  
 Sub macro1()
Dim i As Long, Texto As String, j As Long
For i = 1 To Range("K65536").End(xlUp).Row
         Select Case ActiveCell.Value
         Case 0
             Range("L" & i).Value = "Ok"
         Case Is < 0
             Range("L" & i).Value = "Under"
         Case Else
             Texto = Range("B" & i).Value & Range("D" & i).Value
             With Sheets("Class 2")
                 For j = 2 To .Range("A65536").End(xlUp).Row
                     If (.Range("A" & j).Value & .Range("B" & j).Value) = Texto _
                         And .Range("D" & j).Value = 0 Then
                     ActiveCell.Offset(0, 1).Select
                     ActiveCell.Value = "Above"
                     Exit For
                 End If
             Next j
         End With
     End Select
 Next i
End Sub

Now instead of the j loop we can use .Find to find the cells we want which is much faster than a loop. If you need help with that can you post an attachment so I can see what is going on?

[Paleo]

Hi Jake,

thanks. Could you post a small example code that uses .Find? Then I may try to adapt it. All I need is to concatenate cells B and D from a sheet and compare then to the cells A and B (concatenated) from another sheet. Then if they are equal I must test cell Ds value to see if its equal to zero.

[Jacob Hilderbrand]

Ok, see if this works. It's hard to tell without the data to test it.

Option Explicit
  
Sub macro1()
Dim i               As Long
Dim j               As Long
Dim Texto           As String
Dim LastRow         As Long
Dim SearchRange     As Range
Dim Cel             As Range
Dim FirstAddress    As String
LastRow = Range("K65536").End(xlUp).Row
     Set SearchRange = Sheets("Class 2").Range("A2:A" & _
     Sheets("Class 2").Range("A65536").End(xlUp).Row)
For i = 1 To LastRow
         Select Case Range("K" & i).Value
         Case Is = 0
             Range("L" & i).Value = "Ok"
         Case Is < 0
             Range("L" & i).Value = "Under"
         Case Else
             Texto = Range("B" & i).Text & Range("D" & i).Text
             With SearchRange
                 Set Cel = .Find(What:=Range("B" & i).Text, LookIn:=xlValues, _
                 LookAt:=xlWhole, MatchCase:=True)
                 If Not Cel Is Nothing Then
                     FirstAddress = Cel.Address
                     Do
                         If Cel.Offset(0, 1).Text = Range("D" & i).Text And _
                         Sheets("Class 2").Range("D" & Cel.Row) = 0 Then
                         Range("L" & i).Value = "Above"
                         Exit Do
                     End If
                     Set Cel = .FindNext(Cel)
                 Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
             End If
         End With
     End Select
 Next i
End Sub

[Jacob Hilderbrand]

Here is a closer look at how the search works.

'Basic with statement
With SearchRange
'This line sets the range Cel to the cell where our
'matching value is found.
'What:= what we are searching for.
'LookIn:= Either xlValues or xlFormulas depending on
'what we are seaching in.
'LookAt:= Either xlWhole to match the whole cell, or
'xlPart to match part of the cell.
Set Cel = .Find(What:=Range("B" & i).Text, LookIn:=xlValues, _
    LookAt:=xlWhole, MatchCase:=True)
'If there is no match the Cel would be nothing so we
'check with an If statement.
If Not Cel Is Nothing Then
'We store the address of Cel for later use since we don't
'want to infinitely search.
FirstAddress = Cel.Address
'Start of a Do...Loop loop.
        Do
'We already matched Range("B" & i).Text so we need
'to check if the next cell over
'matches Range ("D" & i).Text. We also want to check
'if the value in Column D corresponding to where Cel
'was found is equal to 0.
If Cel.Offset(0, 1).Text = Range("D" & i).Text And _
            Sheets("Class 2").Range("D" & Cel.Row) = 0 Then
'True part of the If statement. This puts the value Above
'in Range("L" & i).
Range("L" & i).Value = "Above"
'Exit the Do...Loop loop since we only need one match.
                Exit Do
            End If
In case we matched Range("B" & i).Text but not
'Range("D" & i).Text we need to find the next matching value.
Set Cel = .FindNext(Cel)
'This will loop through all the matching values of our search.
'If Cel is nothing then there are no matches.
'If Cel.Address = FirstAddress then we found all the cells and
'would now start over. In either case the loop ends.
Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
    End If
End With

[Zack Barresse]

Don't forget, if you also turn off Events and ScreenUpdating, it should speed your code up slightly also ...

Application.EnableEvents = False
Application.ScreenUpdating = False
'...
'...
'turn back on
Application.EnableEvents = True
Application.ScreenUpdating = True

[Paleo]

Great guys,

I believe this is gonna work great. Thanks Jake and Zack. I will test it and post the result here. BRB

[Paleo]

Hi guys,

well it worked fine but still slow for 22,000 rows. Anything else that may make it faster?
It takes me 38 min and 22 secs.

[Zack Barresse]

Well, looping through that many cells will take a very long time. If there is a way you can use AutoFilter, do it. It's very fast.

[Paleo]

Hi Zack,

unfortunatelly I cant use autofilter because I have to treat in a different way cells that have the same result. My judgement will depend on values from 3-7 cells on each row. It takes 38:22 and I have no clue on how to make it faster. I have take select case off and put an if, disabled screenupdating and events but it still slow.

Any suggestions?

[Jacob Hilderbrand]

Well we are still using a huge loop so that will be slow. You can also turn off Automatic Calculations while your code is running. That may shave some more time.

But the big problem is the main loop.

I think I might have another idea for you. I'll try to write it up later tonight.

[johnske]

Hi Paleo,

Jake's right, there's too many "select"s in there. You don't have to select a cell to assign a value to it, in fact I don't think you even need to specify "value" in this case either (as - due to the context in which it's being used - it's assumed you're referring to the value in the specified cell anyway).

See if this helps, it's your original code, but abridged. Admittedly I dont have data in the cells, but when I set it to 20000 rows, with my old 233MHz machine it took 30-35 secs to cycle through, and, when Events were also turned off as Zack suggested, it took 25 secs.

Sub macro1() 
Dim i As Long, Texto As String, j As Long 
Application.ScreenUpdating = False
For i = 1 To Range("K65536").End(xlUp).Row 
Range("K" & i).Select 
Select Case ActiveCell
Case 0 
ActiveCell.Offset(0, 1) = "Ok" 
Case Is < 0 
ActiveCell.Offset(0, 1) = "Under" 
Case Else 
Texto = Range("B" & i) & Range("D" & i)
With Sheets("Class 2") 
For j = 2 To .Range("A65536").End(xlUp).Row 
If (.Range("A" & j) & .Range("B" & j)) = Texto _ 
And .Range("D" & j) = 0 Then 
ActiveCell.Offset(0, 1) = "Above"
Exit For 
End If 
Next j 
End With 
End Select 
Next i 
Range("K1").Select 
End Sub

[Jacob Hilderbrand]

I have no clue on how to make it faster.

Let me know how fast this code runs.

Option Explicit
    
   Sub macro1()
Dim i               As Long
       Dim j               As Long
       Dim Texto           As String
       Dim LastRow         As Long
       Dim SearchRange     As Range
       Dim Cel             As Range
       Dim FirstAddress    As String
       Dim RngOK           As Range
       Dim RngAbove        As Range
       Dim RngUnder        As Range
       Dim RngTemp         As Range
Application.ScreenUpdating = False
       Application.EnableEvents = False
LastRow = Range("K65536").End(xlUp).Row
       Set SearchRange = Sheets("Class 2").Range("A2:A" & _
       Sheets("Class 2").Range("A65536").End(xlUp).Row)
'This needs to be an unused cell.
       Set RngTemp = Range("Z1")
       Set RngOK = RngTemp
       Set RngAbove = RngTemp
       Set RngUnder = RngTemp
       For i = 1 To LastRow
           Select Case Range("K" & i).Value
           Case Is = 0
               Set RngOK = Union(RngOK, Range("L" & i))
           Case Is < 0
               Set RngUnder = Union(RngUnder, Range("L" & i))
           Case Else
               Texto = Range("B" & i).Text & Range("D" & i).Text
               With SearchRange
                   Set Cel = .Find(What:=Range("B" & i).Text, LookIn:=xlValues, _
                   LookAt:=xlWhole, MatchCase:=True)
                   If Not Cel Is Nothing Then
                       FirstAddress = Cel.Address
                       Do
                           If Cel.Offset(0, 1).Text = Range("D" & i).Text And _
                               Sheets("Class 2").Range("D" & Cel.Row) = 0 Then
                               Set RngAbove = Union(RngAbove, Range("L" & i))
                               Exit Do
                           End If
                           Set Cel = .FindNext(Cel)
                       Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
                   End If
               End With
           End Select
       Next i
RngOK.Value = "Ok"
       RngUnder.Value = "Under"
       RngAbove.Value = "Above"
       RngTemp.ClearContents
Set RngOK = Nothing
       Set RngUnder = Nothing
       Set RngAbove = Nothing
       Set RngTemp = Nothing
       Set SearchRange = Nothing
       Set Cel = Nothing
Application.ScreenUpdating = True
       Application.EnableEvents = True
End Sub

[Paleo]

Hi guys,

johnske's code runned on 14:27 (an acceptable time) and jake's on more than 45 minutes (when I gave up, sorry!). The machine is a Pentium 4, 2.66 Ghz and 512 Mb RAM.

[Paleo]

Hi Jack,



well this time I have waited. 46:26.

[johnske]

Frankly, am surprised - the inbuilt Find function is usually much faster

[Jacob Hilderbrand]

Ok, this is the last thing I can think of to speed it up. We can get rid of the second loop completely and use AutoFill instead. Assuming Column Z on Class 2 is not used.

Option Explicit
  
 Sub macro1()
Dim i               As Long
     Dim j               As Long
     Dim Texto           As String
     Dim LastRow         As Long
     Dim SearchRange     As Range
     Dim Cel             As Range
     Dim FirstAddress    As String
     Dim RngOK           As Range
     Dim RngAbove        As Range
     Dim RngUnder        As Range
     Dim RngTemp         As Range
     Dim n               As Long
Application.ScreenUpdating = False
     Application.EnableEvents = False
LastRow = Range("K65536").End(xlUp).Row
     n = Sheets("Class 2").Range("A65536").End(xlUp).Row
     Set SearchRange = Sheets("Class 2").Range("Z2:Z" & n)
Sheets("Class 2").Range("Z2").Value = Sheets("Class 2").Range("A2").Value & _
     Sheets("Class 2").Range("B2").Value
Sheets("Class 2").Range("Z2").AutoFill Destination:= _
     Sheets("Class 2").Range("Z2:Z" & n), Type:=xlDefault
'This needs to be an unused cell.
     Set RngTemp = Range("Z1")
     Set RngOK = RngTemp
     Set RngAbove = RngTemp
     Set RngUnder = RngTemp
     For i = 1 To LastRow
         Select Case Range("K" & i).Value
         Case Is = 0
             Set RngOK = Union(RngOK, Range("L" & i))
         Case Is < 0
             Set RngUnder = Union(RngUnder, Range("L" & i))
         Case Else
             Texto = Range("B" & i).Text & Range("D" & i).Text
             With SearchRange
                 Set Cel = .Find(What:=Texto, LookIn:=xlValues, _
                 LookAt:=xlWhole, MatchCase:=True)
                 If Not Cel Is Nothing And Sheets("Class 2").Range("D" & Cel.Row) = 0 Then
                     Set RngAbove = Union(RngAbove, Range("L" & i))
                 End If
             End With
         End Select
     Next i
RngOK.Value = "Ok"
 RngUnder.Value = "Under"
 RngAbove.Value = "Above"
 RngTemp.ClearContents
 SearchRange.ClearContents
Set RngOK = Nothing
 Set RngUnder = Nothing
 Set RngAbove = Nothing
 Set RngTemp = Nothing
 Set SearchRange = Nothing
 Set Cel = Nothing
Application.ScreenUpdating = True
 Application.EnableEvents = True
End Sub

[johnske]

And this is the last thing I can think of on these lines - getting rid of the only remaining "Select" appears to shave about 20 to 30% off the time...

Sub macro2()
      Dim i As Long, Texto As String, j As Long
      '//allow the "macros" form to be unloaded
      DoEvents
      '//now disable further events
      Application.EnableEvents = False
      Application.ScreenUpdating = False
      For i = 1 To Range("K65536").End(xlUp).Row
            With Range("K" & i)
                  Select Case Range("K" & i)
                  Case 0
                        Range("K" & i).Offset(0, 1) = "Ok"
                  Case Is < 0
                        Range("K" & i).Offset(0, 1) = "Under"
                  Case Else
                        Texto = Range("B" & i) & Range("D" & i)
                        With Sheets("Class 2")
                              For j = 2 To .Range("A65536").End(xlUp).Row
                                    If (.Range("A" & i) & .Range("B" & i)) = Texto _
                                       And .Range("D" & i) = 0 Then
                                          Range("K" & i).Offset(0, 1) = "Above"
                                          Exit For
                                    End If
                              Next j
                        End With
                  End Select
            End With
      Next i
      Range("K1").Select
      '//re-enable events
      Application.EnableEvents = True
      Application.ScreenUpdating = True
End Sub

[Paleo]

Hi John,



your approach have increased performance a little more and I think Jakes approach is gonna be great if I classify data before it. What do you think Jake?

[Aaron Blood]

Hi John,



your approach have increased performance a little more and I think Jakes approach is gonna be great if I classify data before it. What do you think Jake?

Pal,

Can I try?

Could someone post a workbook version of this so I don't have to spend an hour digesting and reconstructing?