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

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?

VB Code:

'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

Bump!

Hi Martin, that's quite a bit of code you've got there! ;)
Can you tell me what the code is trying to achieve & I'll see if there's a way to re-write this for you. Also, can you tell me if you need to use the createobject call to open Excel, i.e. will your users all be using the same version of Excel here?

Thanks :)

Hi Alex,

Yes my users could be using either Office 97 or 2000 so I can't use early binding I'm afraid.

The code I have submitted is really just to provide a demo of the problem (ie the actual app doesn't fill the spreadsheet with random numbers!)

What I am trying to do is write an app to process data in excel spreadsheets returned by sales people.

The number of rows in the spreadsheet can vary and despite instructions to the contrary they sometimes put comments below or above the actual data or blank rows in the middle of the data. I need to sort the data by 2 of the columns anyway prior to processing and selecting all rows in these columns before performing the sort will consolidate the data and remove the blank lines.

I then loop through inspecting the lines to see if they look as though they have been filled in (not all column values are mandatory) and when I get to the first non filled in line I check if the LastCell is outside where it should be. If it is I check if there is a difference between CountA in my expected range is and CountA in the range ended by the last cell.

If so I want to abort processing and comment these fields so that regardless of where on the spreadsheet they are they can easily be found with Goto/Special and manually inspected and corrected by the admin person that will be using the app.

The Find(*) method does this fine. The only problem however is that after using the sort method it takes absolutely ages (about 5 minutes on my Win98/Office 2000 setup). When I haven't called the Sort method though it only takes less than a second to do the same thing!

okkay cool - give me till monday & I'll knock you up a sample! :)

Cheers,

Have you any inkling of an idea though why I should be getting this problem?

The sort method itself doesn't take an undue length of time and I can't see why the fact that I have called it should be even vaguely relevant to the length of time taken by the Find function?

Purely by accident I found that if the Excel Application was visible and
I clicked on it whilst it was hanging on the

Set objFoundCell = PassedRange.FindNext(objFoundCell)

line it returned to the VB application with the correct answer instantly
instead of taking 5 minutes!

I have now got to the stage that sandwiching the line as below works fine...

objXLApplication.Visible = True
objFoundCell.Activate
Set objFoundCell = PassedRange.FindNext(objFoundCell)
objXLApplication.Visible = False

But I don't really want to have to make the app visible at all (the
objFoundCell.Activate line on its own doesn't do it)

This must be a bug but I couldn't find anything on MSDN about it!

Has anyone experienced anything similar before?

If anyone wants to help me troubleshoot this my demo code to date is as
follows...

VB Code:

'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 xlMinimized = -4140
Const xlAscending = 1
Const xlYes = 1
Const xlTopToBottom = 1
Set objXLApplication = CreateObject("Excel.Application")
objXLApplication.WindowState = xlMinimized
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, 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 objXLApplication As Object, 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()
    objXLApplication.Visible = True
    objFoundCell.Activate
    Set objFoundCell = PassedRange.FindNext(objFoundCell)
    objXLApplication.Visible = False
    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

Quote:

---

they sometimes put comments below or above the actual data....

---

If you're only interested in the used range cells which you sorted, can't you just delete any other rows from the sheet?

This one I think might be what you're looking for, note that I did this within Excel, so you might have to alter some of it slightly (ie. declare the excel.application object & specify any Excel constants if vb doesn't pick them up):

VB Code:

Private Sub CommandButton1_Click()
    Dim rngCurrentUsedRange As Range
    Dim rngNonUsedCellRange As Range
    Dim comCellComment As Comment
    
    ' Setup the range of valid data to be sorted
    Set rngCurrentUsedRange = Range("A2:C6")
 
    If Not (rngCurrentUsedRange Is Nothing) Then
        With rngCurrentUsedRange
        
            ' Perform your sorting
            .Sort .Range("B2"), xlAscending, .Range("C2"), , _
            xlAscending, , , xlYes, 1, False, xlTopToBottom
    
            ' Delete any blank rows within this used range
            For Each Cell In rngCurrentUsedRange
                If (WorksheetFunction.CountA(Cell.EntireColumn) = 0) Then
                    Cell.EntireColumn.Delete
                End If
            Next Cell
            
            ' Clear all comments from past used range
            Rows("6:" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).Select
            Selection.ClearComments
        End With
    End If
End Sub

Thanks Alex.

I might end up using that.

I need to check with the customer whether they are happy with this.

At the very least though your code has shown me that my deletion of comments by looping through the ActiveSheet.Comments collection was completely unnecessary

I didn't realise there was a Range.ClearComments function!

I'll be honest - neither did I, but just started looking around at ways of doing this & stumbled across it - I've never needed to do any work with comments before but I'll remember this one if I need it in future! :D