Optimizing VBA

I created this VBA code:

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?

:banghead: :banghead:

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

Code:

---

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?

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.

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

Code:

---

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

---

Here is a closer look at how the search works.

Code:

---

'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

---

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

Code:

---

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

---

Great guys,

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

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.

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.

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?

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.

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.

Code:

---

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

---

Quote:

---

Originally Posted by Paleo

I have no clue on how to make it faster.

---

Let me know how fast this code runs.

Code:

---

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

---

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.

Hi Jack,



well this time I have waited. 46:26.

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

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.

Code:

---

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

---

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

Code:

---

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

---

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?

Quote:

---

Originally Posted by 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?

---

Pal,

Can I try?

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