frank_m
04-26-2012, 12:20 PM
I wrote this routine to find colored rows, (except move on to the next if the Column A cell is colored red. - It works fine if rows are not filtered and also works ok with filtered rows unless there are alot of results. ie: 7,500 results out of 14,000 rows. - In that case it finds the first colored row ok in my sample workbook, but takes 5 seconds or more to find the 2nd colored row. Then after that other colored rows are found faster. - Is there anything I can do to improve this?
Edit: Had trouble uploading the sample file because of its size.. I managed to reduce it and now it is attached.
Option Explicit
Private Sub CommandButton1_Click()
Dim Found As Range
Dim StrtAdrss As String
Dim Rng As Range
Dim Lastrow As Long
With ActiveSheet
Lastrow = .Cells.SpecialCells(xlCellTypeVisible).Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set Rng = .Range(.Cells(1, 1), .Cells(Lastrow, 20)).SpecialCells(xlCellTypeVisible)
End With
If ActiveCell.Column > 20 Then ActiveCell.EntireRow.Cells(1).Activate
StrtAdrss = ActiveCell.Address
Application.ScreenUpdating = False
Set Found = Rng.Find(What:="*", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
'Loop Until any Colored Row is found ( except skip rows with red in Col(A)
Do Until Found.Interior.ColorIndex <> xlNone _
And Found.EntireRow.Cells(1).Interior.ColorIndex <> 3 _
And Found.Row > 15 And StrtAdrss <> Found.Address
Set Found = Rng.FindNext(Found)
Loop
ActiveWindow.ScrollRow = Found.Row 'scrolls found row to the top
Application.ScreenUpdating = True
'activate last col cell incase multiple colored cells in row, next search finds next colored row
Found.EntireRow.Cells(20).Activate
ActiveWindow.ScrollColumn = 1 ' keeps Col(A) in view when found cell is out of view
Else
MsgBox "No Match Found"
End If
End Sub
Thanks
Edit: Had trouble uploading the sample file because of its size.. I managed to reduce it and now it is attached.
Option Explicit
Private Sub CommandButton1_Click()
Dim Found As Range
Dim StrtAdrss As String
Dim Rng As Range
Dim Lastrow As Long
With ActiveSheet
Lastrow = .Cells.SpecialCells(xlCellTypeVisible).Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set Rng = .Range(.Cells(1, 1), .Cells(Lastrow, 20)).SpecialCells(xlCellTypeVisible)
End With
If ActiveCell.Column > 20 Then ActiveCell.EntireRow.Cells(1).Activate
StrtAdrss = ActiveCell.Address
Application.ScreenUpdating = False
Set Found = Rng.Find(What:="*", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
'Loop Until any Colored Row is found ( except skip rows with red in Col(A)
Do Until Found.Interior.ColorIndex <> xlNone _
And Found.EntireRow.Cells(1).Interior.ColorIndex <> 3 _
And Found.Row > 15 And StrtAdrss <> Found.Address
Set Found = Rng.FindNext(Found)
Loop
ActiveWindow.ScrollRow = Found.Row 'scrolls found row to the top
Application.ScreenUpdating = True
'activate last col cell incase multiple colored cells in row, next search finds next colored row
Found.EntireRow.Cells(20).Activate
ActiveWindow.ScrollColumn = 1 ' keeps Col(A) in view when found cell is out of view
Else
MsgBox "No Match Found"
End If
End Sub
Thanks