Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Westi on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Applying row colours when auto filter is on 2

Status
Not open for further replies.

bluegnu

Technical User
Sep 12, 2001
131
GB
I have put together some code to a sheet which looks at the value for each active cell in column A and then colours the row accordingly.

Column A will be full of products and what I do is colour each product alternately blue and yellow.

So what you may have is:

A B C
Product Reference Priority
Win2000 w2k01 H
Win2000 w2k02 M
Win2000 w2k03 L
Win2003 w2k301 M
Win2003 w2k302 M
WinXP wxp01 H
WinXP wxp02 L

In this instance the code would colour all the Win2000 as blue, then the Win2003 as yellow and then the WinXP as blue and so on.

The code is:
Code:
       If Cells(rowcnt, 1).Value = Cells(rowcnt - 1, 1) Then
        Clor = Clor
        Else
        If Clor = 1 Then
        Clor = 0
        Else
        Clor = 1
        End If
        End If
        If Clor = 1 Then
        ActiveSheet.Range(Cells(rowcnt, 1), Cells(rowcnt, 8)).Interior.ColorIndex = 19
        Else
        ActiveSheet.Range(Cells(rowcnt, 1), Cells(rowcnt, 8)).Interior.ColorIndex = 20
        End If
        Next rowcnt

The problem is, when you apply an autofilter the colouring obviously goes awry. In the above example, if I filter out Win2003 then I would just have a blue block of products when ideally the code would only work on the visible items. (so Win2000 would be blue and Winxp would be yellow)

Is it possible for my code to only look at the visible items?

many thanks
 
You may play with SpecialCells(xlCellTypeVisible)

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Thanks for the response. I can see that this will probably work, but having tried I am sturggling to see how to get it to work with my code.

Here is the full code:

Code:
Private Sub Worksheet_Activate()

'added by Stu 22/03/2007
ActiveSheet.unprotect
'end
'Added by Stu 12/09/2008
'Set up unique number for each increment reference
    Columns("I:I").EntireColumn.Hidden = True
    
Dim ws2 As Worksheet
Dim Beginrow As Long
Dim Endrow As Long
Dim Clor As Long

Beginrow = 2
   
    ' Find the FIRST EMPTY row by adding 1 to the last row
    Endrow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row + 1
ChkCol = 9

        For rowcnt = Beginrow To Endrow
        Dim MaxNo As Long
        Dim Rng As Range
        Set Rng = Range("i1", Range("i65536").End(xlUp))
        MaxNo = Application.WorksheetFunction.Max(Rng)
            If Cells(rowcnt, 1).Value = "" Then
            Cells(rowcnt, 1).Value = ""
            Else
            If Cells(rowcnt, ChkCol).Value = "" Then
                Cells(rowcnt, ChkCol).Value = MaxNo + 1
 '       End If
        End If
 '       End If
     '   End If
        End If
        
                
'Now set the colour for that row

        If Cells(rowcnt, 1).Value = Cells(rowcnt - 1, 1) Then
        Clor = Clor
        Else
        If Clor = 1 Then
        Clor = 0
        Else
        Clor = 1
        End If
        End If
        If Clor = 1 Then
        ActiveSheet.Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 19
        Else
        ActiveSheet.Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 20
        End If
        Next rowcnt


' Auto Filter by Product
Range("A1:H616").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

    Cells(1, 1).Select

   ActiveSheet.protect AllowFiltering:=True

End Sub

Now having used specialcells the cells flash blue then yellow and eventually stop! Any help is very much appreciated.
 


Code:
Beginrow = 2
   
    ' Find the FIRST EMPTY row by adding 1 to the last row
    Endrow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row + 1
ChkCol = 9

DIM r as range

        For each r in range(cells(beginrow,"A"), cells(endrow,"A")).specialcells(xlcelltypevisible)
           rowcnt = r.row
'.......
        next r

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top