Weird Excel VBA "Find" and "Sort" issue.

[MartinSmith]

I have a strange problem with automating Excel from VB. When using the Find function to cycle through nonblank
cells in a large range it takes less than a second to run if I haven't used the sort function previously but more
than 5 minutes if I have!

(If anyone wants to check this code out just paste the following code into a standard VB module then run it with the sort line commented and uncommented and see!)

Has anyone any explanation/solution/work around for this behaviour?

'Paste this code into a standard vbmodule.
Option Explicit
 
Private Sub Main()
    If Dir("C:\Test.xls") = "" Then
    Open "C:\Test.xls" For Output As #1
    Close #1
    End If
Dim collCells As Object, collComments As Object, objComment As Object
Dim i As Long, objXLApplication As Object, lngNumberOfCellsToFind As Long
Const xlAscending = 1
Const xlYes = 1
Const xlTopToBottom = 1
Set objXLApplication = CreateObject("Excel.Application")
objXLApplication.Visible = False
objXLApplication.Workbooks.Open ("C:\Test.xls")
objXLApplication.ActiveSheet.Cells.ClearContents
 
 
Set collComments = objXLApplication.ActiveSheet.Comments
    For Each objComment In collComments
    objComment.Delete
    Next
Set collComments = Nothing
 
 
 
Set collCells = objXLApplication.Range("A2:U52").Cells
    For i = 1 To collCells.Count
    collCells(i).Value = Int((100 * Rnd) + 1)
    Next
Set collCells = Nothing
 
objXLApplication.Range("B53").Value = "First dodgy cell"
objXLApplication.Range("IV65536").Value = "Second dodgy cell"
lngNumberOfCellsToFind = 2
 
'THIS IS THE PROBLEM LINE BELOW!!!!!
'objXLApplication.ActiveSheet.Columns("A:U").Sort objXLApplication.Range("N2"), xlAscending, objXLApplication.Range("S2"), , xlAscending, , , xlYes, 1, False, xlTopToBottom
 
CommentNonBlankCells objXLApplication.Range("A53:IV65536"), lngNumberOfCellsToFind
objXLApplication.DisplayAlerts = False
objXLApplication.ActiveWorkbook.SaveAs FileName:="C:\Test.xls", FileFormat:=-4143, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
objXLApplication.ActiveWorkbook.Close True
objXLApplication.Quit
Set objXLApplication = Nothing
End Sub
Private Sub CommentNonBlankCells(ByRef PassedRange As Object, ByRef lngNumberOfCellsToFind As Long)
Dim objFoundCell As Object, strFirstAddressInRange As String, blnExitDo As Boolean
Const xlFormulas = -4123
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Set objFoundCell = PassedRange.Find("*", , xlFormulas, xlPart, xlByRows, xlNext, False)
    If TypeName(objFoundCell) = "Nothing" Then Exit Sub
lngNumberOfCellsToFind = lngNumberOfCellsToFind - 1
strFirstAddressInRange = objFoundCell.Address
objFoundCell.AddComment ("Data outside expected area")
    Do Until blnExitDo Or (lngNumberOfCellsToFind = 0)
    DoEvents
    Debug.Print Now()
    'THIS IS THE LINE THAT CAN TAKE TOO LONG BELOW!!!!!
    Set objFoundCell = PassedRange.FindNext(objFoundCell)
    Debug.Print Now()
        If objFoundCell.Address = strFirstAddressInRange Then
        blnExitDo = True
        Else
        objFoundCell.AddComment ("Data outside expected area")
        lngNumberOfCellsToFind = lngNumberOfCellsToFind - 1
        End If
    Loop
Set objFoundCell = Nothing
End Sub