Method to highlight names with consecutive attendance

[AlexCHI]

I am using Excel 2007 and asking your help for the best (and the easiest) way to highlight the names of people who have 6-month of consecutive attendance every Sundays.

My worksheet's layout are as follow:
Column A: Last Name
Column B: First Name
Row 9: Dates (with "S9" as Jan 01, 2017 thru "NS9" as Dec 31, 2017)
Row 10: Days (with "S10" as Sunday thru "NS10" as Sunday)

The attendance is taken by marking an "X" in the Sunday columns (i.e., 1/01/2017, 1/08/2017, 1/15/2017 and so on). So whoever attends every Sunday for 6-month straight would have their names (last/first) in column A/B highlighted. I am not sure if conditional formatting can achieve this or VBA? I greatly appreciate your input and please kindly provide the steps to achieve this. Thank you in advance!

 

[AlexCHI]

Hi Oldbrewer,

Thank you for your reply. In response to your question, I want every individual who ever had a 6-month consecutive Sunday attendance highlighted. Those who ever had a 6-month consecutive Sunday attendance will be qualified as a member and have their names highlighted to show eligibility. Any more (or less) attendance thereafter does not affect their membership. Also, the 6-month run can start any Sunday and not necessay to begin in January. Hope this clarifies things a bit. Thank you again.

 

[MickG]

Try this example :-
https://app.box.com/s/m4kth2ld9gjn3i8y4jrwnw1bl11wxdam

 

[oldbrewer]

01/01/2017

08/01/2017

15/01/2017

22/01/2017

29/01/2017

05/02/2017

12/02/2017

19/02/2017

26/02/2017

05/03/2017

fred

X

X

X

X

X

X

X

bill

X

X

X

X

X

X

X

as before for testing purposes we are looking for any 3 consecutive attendances

scores

fred

0

< < < L14

bill

1

1

2

THE HELPER ROWS find all runs of 3 or more

fred has none of course

any total greater than zero makes a person a member

now we just use conditional formatting on the names in the top table

the formula applied to fred is =L14>0

copied with format painter to bill

bill is highlighted yellow

<colgroup><col><col span="2"><col span="12"></colgroup><tbody>
</tbody>

 

[AlexCHI]

Try this example :-
https://app.box.com/s/m4kth2ld9gjn3i8y4jrwnw1bl11wxdam

Hi Mick,

Thank you SO much for the extent of work you had done to help me out. It worked perfectly on my worksheet now! One little bump though... I had changed this line "If c >= 26 Then Dn.Resize(, 2).Interior.Color = vbYellow" to "If c >= 26 Then Dn.Resize(, 2).Font.Bold = True" and the code (i.e., making or dis-making the font bold) doesn't run as smooth as the yellow highlighting. For instance, if I remove some "AM"s or "PM"s from a 26+ weeks consecutive attended name, then oddly the name stays bold even though the attendance is no longer 6-consecutive-month. Is there a reason for this?

Also, would you please show me the line of code that instead of yellow highlight, the names in column A and B would be bold and in blue color?

Lastly Mick, I know this is a lot to ask of you but I really want to learn the thought process behind each line of codes you compiled below. Is it at all possible if you can teach me what each line means?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range, Dn As Range, Ac1 As Long, Ac2 As Long, c As Long
Dim Lst As Long
Set Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))

If Not Intersect(Target, Rng.Offset(, 19).Resize(, 365)) Is Nothing And Target.Count = 1 Then
Rng.Resize(, 2).Interior.Color = xlNone

For Each Dn In Rng
 c = 0
 For Ac1 = 0 To 196 Step 7
    For Ac2 = Ac1 To Ac1 + 182 Step 7
        If UCase(Dn.Offset(, Ac2 + 19)) = "AM" Or UCase(Dn.Offset(, Ac2 + 19)) = "PM" Or UCase(Dn.Offset(, Ac2 + 19)) = "AM & PM" Then
            c = c + 1
           If c >= 26 Then Dn.Resize(, 2).Interior.Color = vbYellow
        Else
            c = 0
            Exit For
        End If
    Next Ac2
  Next Ac1
Next Dn
End If
End Sub

 

[MickG]

Try this :-
If it works I'll add some code comments.
NB:- For some reason the code becomes a bit slower when the "Font,Bold" is used.

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Rng.Offset(, 19).Resize(, 365)) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Rng.Resize(, 2)
    .Interior.Color = xlNone
    .Font.Bold = False
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
 c = 0
 [COLOR="Navy"]For[/COLOR] Ac1 = 0 To 196 [COLOR="Navy"]Step[/COLOR] 7
    [COLOR="Navy"]For[/COLOR] Ac2 = Ac1 To Ac1 + 182 [COLOR="Navy"]Step[/COLOR] 7
        [COLOR="Navy"]If[/COLOR] UCase(Dn.Offset(, Ac2 + 19)) = "AM" Or UCase(Dn.Offset(, Ac2 + 19)) = "PM" Or UCase(Dn.Offset(, Ac2 + 19)) = "AM & PM" [COLOR="Navy"]Then[/COLOR]
            c = c + 1
           [COLOR="Navy"]If[/COLOR] c >= 26 [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]With[/COLOR] Dn.Resize(, 2)
                    .Interior.ColorIndex = 33
                    .Font.Bold = True
                [COLOR="Navy"]End[/COLOR] With
           
           [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Else[/COLOR]
            c = 0
            [COLOR="Navy"]Exit[/COLOR] For
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac2
  [COLOR="Navy"]Next[/COLOR] Ac1
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] If
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[AlexCHI]

Try this :-
If it works I'll add some code comments.
NB:- For some reason the code becomes a bit slower when the "Font,Bold" is used.

Hi Mick.

Your code works perfectly! Thank you so much again. Being a newbie in the world of excel VBA, I didn't imagine my worksheet could turn out so well with the help of so many on this forum. I really appreciate your willingness to explain to me your lines of coding. Before doing so though, I have another issue hoping you could lend a hand (if it's not too much of a trouble). If it's going to be rewriting everything then please discard my request since I am already content with how the worksheet is working now...

The current issue is besides from your code, I have two other worksheet_change codes running- to hide and show columns with the date(s) and days as inputted in cell B3 (for date) and cell B5 (for day). There is a compile error of "duplicate declaration in current scope" if I paste your code after the two other codes shown below. And in the fear of messing it up because of my lack of proficiency in excel VBA, what I did was I pasted your code as a worksheet_selectionchange code instead. It works but the highlighting of the names would not "refresh" unless a cell in the same row be selected whereas if the code is running as a worksheet_change then the highlighting "refreshes" as soon as the value of the cell is modified. Your thought?

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim OneDate As Variant
  Dim InvalidDates As String
  
  If Not Intersect(Target, Range("B3")) Is Nothing Then
    Application.ScreenUpdating = False
    If IsEmpty(Range("B3").Value) Then
      Columns("T:NT").Hidden = False
    Else
      Columns("T:NT").Hidden = True
      For Each OneDate In Split(Replace(Range("B3").Value, ", ", ","), ",")
        If IsDate(OneDate) Then
          Columns("T").Offset(, CDate(OneDate) - Range("T9").Value).Hidden = False
        Else
          InvalidDates = InvalidDates & vbLf & OneDate
        End If
      Next OneDate
    End If
    Application.ScreenUpdating = True
    If Len(InvalidDates) > 0 Then MsgBox "Invalid Dates Entered:" & InvalidDates
  End If
  
  Dim sDay As String
  Dim rFound As Range
  Dim c As Long
  
  If Not Intersect(Target, Range("B5")) Is Nothing Then
    Application.ScreenUpdating = False
    sDay = Left(Range("B5").Value, 3)
    Columns("T:NT").Hidden = False
    If Len(sDay) > 0 Then
      Set rFound = Range("S10:NT10").Find(What:=sDay, After:=Range("S10"), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, SearchDirection:=xlNext, SearchFormat:=False)
      If Not rFound Is Nothing Then
        Columns("T:NT").Hidden = True
        For c = rFound.Column To Columns("NT").Column Step 7
          Columns(c).Hidden = False
        Next c
      End If
    End If
    Application.ScreenUpdating = True
  End If
End Sub

 

[MickG]

I don't totally see what you code/s are trying to do except basically hide columns, but I don't see why you can't place them all in the same "Change_Event". NB:- You can't have a more than one of the same change events in the same sheet
As each separate code is initiated by the target cell being either a specific cell or specific range of cells, and none of those cells are an intersect of the others, then only one code at a time will run depending on your target cell.
I should give it a go see what happens. !!!!!