some rows wanted

[shrivallabha]

Hi,

Thanks for the wishes. I guess, following shall work. Only thing that you need to do is match colors (Shades of Red, Orange & Green) used in Cells L6, M6 & N6 in the rows where you want to set color filter as my code refers to these cells for color match. Currently they do not match except column L (Red). Especially the selectionchange event color setting.

The color filter is set in Cell K1. This was a bit of rework as I had not considered such possibility while doing the first part.

This is the main event which looks at which filter is being used: B1 or K1
[VBA]Public rTarget As Range
Public iCol As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Address = "$B$1" Then
Set rTarget = Target
Call HideSpecificRows
ElseIf Target.Address = "$K$1" Then
If Target.Value <> "None" Then
If Target.Value = "Red" Then iCol = 12
If Target.Value = "Orange" Then iCol = 13
If Target.Value = "Green" Then iCol = 14
Set rTarget = Range("B1")
Call HideColoredRows
Else
Set rTarget = Range("B1")
Call HideSpecificRows
End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub[/VBA]
Some conditions needed shifting from above event to this routine.
[VBA]Private Sub HideSpecificRows()
Dim rToCheck As Range, r As Range
If rTarget.Value = "ALL" Then
Cells.EntireRow.Hidden = False
Else
Cells.EntireRow.Hidden = False
Set rToCheck = Range("A8:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each r In rToCheck
If InStr(r.Value, rTarget.Value) = 0 Then
r.EntireRow.Hidden = True
Else
r.EntireRow.Hidden = False
End If
Next r
End If
End Sub[/VBA]
And before applying color filter it reworks the base filter in B1 as this sub calls Sub above "HideSpecificRows".
[VBA]Private Sub HideColoredRows()
Dim rColCheck As Range, r As Range
Call HideSpecificRows
Set rColCheck = Range("B8:B" & Cells(Rows.Count, 2).End(xlUp).Row) _
.SpecialCells(xlCellTypeVisible)
For Each r In rColCheck
If Cells(r.Row, iCol).Interior.Color <> Cells(6, iCol).Interior.Color Then _
r.EntireRow.Hidden = True
Next r
End Sub
[/VBA]
I am attaching the revised workbook.

[JEPEDEWE]

Hi...
Tried to change the code for the colour....
Green works now, but orange (255,204,0) doesn't... strange
send you the modified file

Thanks again
JP

[JEPEDEWE]

Hi,

In filtering the colour, I loose my titles

Can I move the listboxes to a more "user-friendly" location
Change the englich names into dutch ones?
(red=rood, green=groen, orange=oranje, none=geen, All=alle)

thanks
JP

[shrivallabha]

Hi,

I have changed the location of the color option to C1 which is next to the filter in B1. I have used the Dutch substitutes as you have provided.

For time being I have removed the other selectionchange macro. Now the rest of the code works fine on all colors.

I am attaching the file.

[JEPEDEWE]

Sorry to keep bothering you...

As I noticed before, when filtering on colours, I loose the titles...
This doesn't happen when I filter on LL or LK or B

Could you change the code to keep the titles after selecting a colour???

What's the use of the red cel L1???

Hope I still ca count on you so close to the end! (to perfection)

Thanks a lot for your time spend on this project

JP

[shrivallabha]

Well, whatever that I know about VBA is mostly due to VBAX. I come here to learn things.

What I have done is adding the color to the heading row so you won't lose them. To make the logic clear, I have added comments to cell L10, L15 and L19 of the revised workbook. Reading them shall clarify my idea to you.

The red color in L1 was after effect of the selectionchange macro which I deleted. I have removed the color.

Somewhere, you stated the purpose of this sheet (Children's cause). I am a contributor of Plan India organization which works for orphans. So this will make me happier if it works for you.

I am attaching revised workbook.

[JEPEDEWE]

sorry to say, the filtering works, but the "clicking-to-get-a-colour" no longer works.....maybe you deleted too much... I don't know

I already work 31 years with disabled children, age from 12 to 19-20.
some have a mental handicap some have serious character problems...

I love my job very much...

The sheet helps us to see where our kids run into dangerous situations and what we can do about this.
The progamr is not really for me personally since I am a fysical therapist, the sheet should help some of my collegues.

Thanks for your very kind help

(not for me personally but for our kids!!... thanks a lot)
JP

[shrivallabha]

Hi,

Now you have confused me. There is no change in the code whatsoever from the previous post. So there is nothing deleted.

The only changes that I have made are in the cells L, M & N of Titles. I have added relevant colors so that the Title row does not hide when the code runs. Have you read the comments written? Move the mouse cursor over the cells L10, L15 and L19 to read comments.

The filters work perfectly for me so I can not replicate the problem here. Sorry for that.

Can you please upload the workbook where it is not working for you so that I can compare?

[JEPEDEWE]

Strange... I send you the file...

click on one of the cells in column L or M or N or O... the corresponding color should be applied, but nothing happens

I send you the file with a working color-thing
please see the difference with the latest one you send where the color-thing doesn't work

also, in this file, cell O1 has no cell edge...dono why

Thanks mate!
JP

[shrivallabha]

This is not the latest! Ah, I think that could be the problem.
Please download the one posted at post number#26 and check or see the attached file in this reply.

This time I have added word Final to its name so that old and new don't get mixed up

[JEPEDEWE]

this is very strange... nor your latest version nor the version of reply 26 work...
Clicking the cell should change the cell-color... but nothing happens in both files. In my uploaded file the color program works just fine but the rest doesn't
.... complicated

JP

[shrivallabha]

No, that isn't strange. As I have specified in the post #24, the macro which colors your cells is removed.

Do you need the "selectionchange" macro?
I think this is what it does:
When you click on L, M or N column it assigns color to the specific column based on the column number and removes the color from the other two columns (as only one color will be applicable?). Can you clarify or confirm your requirement? I can work it out then!

[JEPEDEWE]

seen #29... this file does exactly what it should do with the color-cells...
Hope you can solve this problem!
thanks a lot
JP

[shrivallabha]

seen #29... this file does exactly what it should do with the color-cells...
Hope you can solve this problem!
thanks a lot
JP

OK. I refered to the code. Based on understanding and your additional requirement, I have written code as below. This is similar to old code in logic.
[VBA]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'********************************************************************
'This code applies to Column L, M, N & O columns
'Applies color to the selected cell based on column
'Execution of this code calls for another sub updateheading
'********************************************************************
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Count > 1 Or Target.Row < 11 Then GoTo EOSub
If Target.Column < 12 Or Target.Column > 15 Then GoTo EOSub
Set rcTarget = Target
Select Case Target.Column
Case 12
Range("L" & Target.Row).Interior.ColorIndex = 3
Range("M" & Target.Row).Interior.ColorIndex = -4142
Range("N" & Target.Row).Interior.ColorIndex = -4142
Range("O" & Target.Row).Interior.ColorIndex = -4142
Call UpdateHeading
Case 13
Range("L" & Target.Row).Interior.ColorIndex = -4142
Range("M" & Target.Row).Interior.ColorIndex = 46
Range("N" & Target.Row).Interior.ColorIndex = -4142
Range("O" & Target.Row).Interior.ColorIndex = -4142
Call UpdateHeading
Case 14
Range("L" & Target.Row).Interior.ColorIndex = -4142
Range("M" & Target.Row).Interior.ColorIndex = -4142
Range("N" & Target.Row).Interior.ColorIndex = 43
Range("O" & Target.Row).Interior.ColorIndex = -4142
Call UpdateHeading
Case 15
Range("L" & Target.Row).Interior.ColorIndex = -4142
Range("M" & Target.Row).Interior.ColorIndex = -4142
Range("N" & Target.Row).Interior.ColorIndex = -4142
Call UpdateHeading
End Select
EOSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/VBA]
However, this code does not handle updating titles and adding that code to the above event would have made it messy.
[VBA]Private Sub UpdateHeading()
'********************************************************************
'This code updates Title color based on subordinate cells color
'This code gets executed when selectionchange event occurs & applies!
'********************************************************************
Dim lTop As Long, lBot As Long
Dim bColRed As Boolean, bColOra As Boolean, bColGre As Boolean
lTop = Range("B" & rcTarget.Row).End(xlUp).Offset(1, 0).Row
If Range("B" & rcTarget.Row).Offset(1, 0).Value = "" Then
lBot = rcTarget.Row
Else
lBot = Range("B" & rcTarget.Row).End(xlDown).Row
End If
For i = lTop To lBot
If Range("L" & i).Interior.ColorIndex = 3 Then bColRed = True
If Range("M" & i).Interior.ColorIndex = 46 Then bColOra = True
If Range("N" & i).Interior.ColorIndex = 43 Then bColGre = True
Next i
If bColRed = True Then
Range("L" & lTop - 1).Interior.ColorIndex = 3
Else
Range("L" & lTop - 1).Interior.ColorIndex = -4142
End If
If bColOra = True Then
Range("M" & lTop - 1).Interior.ColorIndex = 46
Else
Range("M" & lTop - 1).Interior.ColorIndex = -4142
End If
If bColGre = True Then
Range("N" & lTop - 1).Interior.ColorIndex = 43
Else
Range("N" & lTop - 1).Interior.ColorIndex = -4142
End If
End Sub[/VBA]

I am attaching the updated workbook. I have added R0 to the name for easy identification.

[JEPEDEWE]

OK, I understand, however, 2 remarks (sorry)

now, only titles form level 2 are displayed (2.1 or 2.3 or whatever) but not a level 1 title (example 2 when 2.1 or 2.3 are selected)
Is it possible to set the color next to the titles invisible??? looks cluttery after filtering now...

Thanks

JP

[shrivallabha]

OK, I understand, however, 2 remarks (sorry)

now, only titles form level 2 are displayed (2.1 or 2.3 or whatever) but not a level 1 title (example 2 when 2.1 or 2.3 are selected)
Is it possible to set the color next to the titles invisible??? looks cluttery after filtering now...

Thanks

JP

1. It will be difficult to set Titles color with the current sheet layout.

2. With the second request, you have confused me. Let me understand following:
The code for changing colors is for quick change by clicking on respective column. So if these columns are invisible, then you will have to make them visible to change colors. Aren't these two requests opposite.

If the coloring in the cells remains constant then why not do it once manually as I had done before?

[JEPEDEWE]

1. do you think it is doable??? just asking
2. now it works perfect but because of the cluttery result (after color-filtering), I thought, maybe it is possible to hide the colors next to the titles so the outcome looks better (or to place the colors in colums P Q R S and to hide them... or to change the colors next to the titles into white characters... dono what would be possible)

can I add 2 extra rows (3 - 4) so I can place the title of the sheet (D1) in cell C3....

Thanks

[JEPEDEWE]

I encountered a few errors...

Example: row 15 and 19 (title-items), I can change the color-rectangles... how can I prevent it form being edited

When I change colors in row 26 (what should not be possible) the rectangles in 24 are modified.... strange

JP

[shrivallabha]

1. do you think it is doable??? just asking
2. now it works perfect but because of the cluttery result (after color-filtering), I thought, maybe it is possible to hide the colors next to the titles so the outcome looks better (or to place the colors in colums P Q R S and to hide them... or to change the colors next to the titles into white characters... dono what would be possible)

can I add 2 extra rows (3 - 4) so I can place the title of the sheet (D1) in cell C3....

Thanks

2. I will answer 2nd first. I have shifted it further to Q R S T. So had to jump around in the coding. I think, you should not hide them but it is just my opinion, change it the way you like. If you don't require it, we can still remove the code and do the setup manually. That will spare us from one complete event.

1. This part is little trickier but I think, I have managed it by writing really ugly bit of code as below:
[VBA]Private Sub MainHeadingCheck()
'********************************************************************
'This code updates The main title colors
'This code gets executed when selectionchange event occurs & applies!
'********************************************************************
Dim rTitle As Range, rTCheck As Range
Dim lLast As Long
Dim iMax As Integer
Dim sSearch As String
Dim vSecCheck As Variant
Dim bTColRed As Boolean, bTColOra As Boolean, bTColGre As Boolean

'********************************************************************
'Collecting the titles based on number on left side
'********************************************************************
For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
If IsNumeric(Left(Trim(Range("B" & i).Value), 3)) Then
vSecCheck = Split(Range("B" & i).Value, ".")
If IsNumeric(vSecCheck(1)) Then
If rTitle Is Nothing Then
Set rTitle = Range("B" & i)
Else
Set rTitle = Union(rTitle, Range("B" & i))
lLast = i
End If
End If
End If
Next i
'********************************************************************
'Checking the highest heading number which is currently 10
'********************************************************************
vSecCheck = Split(Trim(Range("B" & lLast).Value), ".")
iMax = vSecCheck(0)
For i = 1 To iMax
'********************************************************************
'Very similar logic to UpdateHeading sub but only titles are checked!
'********************************************************************
For Each rTCheck In rTitle
vSecCheck = Split(Trim(rTCheck), ".")
If CStr(i) = vSecCheck(0) Then
If Range("Q" & rTCheck.Row).Interior.ColorIndex = 3 Then bTColRed = True
If Range("R" & rTCheck.Row).Interior.ColorIndex = 46 Then bTColOra = True
If Range("S" & rTCheck.Row).Interior.ColorIndex = 43 Then bTColGre = True
End If
Next rTCheck

sSearch = i & ". "

'********************************************************************
'Finding the header row which matches sSearch and setting its colors!
'********************************************************************
For j = 10 To Range("B" & Rows.Count).End(xlUp).Row
If Left(Trim(Range("B" & j).Value), 3) = sSearch Then
If bTColRed = True Then
Range("Q" & j).Resize(2, 1).Interior.ColorIndex = 3
bTColRed = False
Else
Range("Q" & j).Resize(2, 1).Interior.ColorIndex = -4142
End If
If bTColOra = True Then
Range("R" & j).Resize(2, 1).Interior.ColorIndex = 46
bTColOra = False
Else
Range("R" & j).Resize(2, 1).Interior.ColorIndex = -4142
End If
If bTColGre = True Then
Range("S" & j).Resize(2, 1).Interior.ColorIndex = 43
bTColGre = False
Else
Range("S" & j).Resize(2, 1).Interior.ColorIndex = -4142
End If
End If
Next j
Next i
End Sub[/VBA]

[shrivallabha]

I encountered a few errors...

Example: row 15 and 19 (title-items), I can change the color-rectangles... how can I prevent it form being edited

When I change colors in row 26 (what should not be possible) the rectangles in 24 are modified.... strange

JP

It is just that one reply would big to read, I have split my reply.

Your observation is correct. I missed it completely. But that should be applicable where Column B is blank e.g. B16, B20 also. So I have added two checkpoints to selection change event as below:
[vba]If Range("B" & Target.Row).Value = "" Then GoTo EOSub
If Range("B" & Target.Row).Offset(-1, 0).Value = "" Then GoTo EOSub[/vba]

I have added two more rows as you specified. Please do not add rows as I have hard coded the starting row part and then code will not work correctly.

I am attaching the revised file. I have changed the revision from R0 to R1.0 to avoid confusion.