Farvelægning af celler - igen, igen.

Jeg vil meget gerne have erstattet en betinget formatering med VB-kode, da den betingede formatering sløver mit ark gevaldigt.
Det drejer sig om farvning af helligdag - igen, igen.

Nedenstående VB-kode har jeg fra et andet regneark:

  På selve arket:

********** 
 
Option Explicit

Private Const msRNG_START As String = "Start"

Private Sub Worksheet_Change(ByVal Target As Range)
    'Flemming Dahl, November 2005, fvd@smartoffice.dk
    If Not Intersect(Target, Range(msRNG_START)) Is Nothing Then
        ColorWeekendsAndHolidaies Me.Name
        Application.Calculate
    End If
End Sub

***********

og i et modul:

***********

Option Explicit

Function ErHelligdag(ByVal TestDato As Long, _
    Optional ByVal InclLørdage As Boolean = True, _
    Optional ByVal InclSøndage As Boolean = True) As Boolean
   
    Dim InputYear As Integer, PD As Long, OK As Boolean
    If TestDato <= 0 Then TestDato = Date
    InputYear = Year(TestDato)
    PD = Påskedag(InputYear)
    OK = True
    Select Case TestDato
        Case DateSerial(InputYear, 1, 1) ' Nytårsdag
        Case PD - 7    ' Palmesøndag
        Case PD - 3    ' Skærtorsdag
        Case PD - 2    ' Langfredag
        Case PD        ' Påskedag
        Case PD + 1    ' 2. påskedag
        Case PD + 26    ' St. Bededag
        Case PD + 39    ' Kristi Himmelfartsdag
        Case PD + 49    ' Pinsedag
        Case PD + 50    ' 2. Pinsedag
        Case DateSerial(InputYear, 12, 25) ' Juledag
        Case DateSerial(InputYear, 12, 26) ' 2. Juledag
        Case DateSerial(InputYear, 12, 31) ' Nytårsaftensdag
        Case Else
            OK = False
            If InclLørdage Then
                If Weekday(TestDato, vbMonday) = 6 Then
                    OK = True
                End If
            End If
            If InclSøndage Then
                If Weekday(TestDato, vbMonday) = 7 Then
                    OK = True
                End If
            End If
    End Select
    ErHelligdag = OK
End Function

Function Påskedag(InputYear As Integer) As Long
    Dim d As Integer
    d = (((255 - 11 * (InputYear Mod 19)) - 21) Mod 30) + 21
    Påskedag = DateSerial(InputYear, 3, 1) + d + (d > 48) + 6 - _
        ((InputYear + InputYear \ 4 + d + (d > 48) + 1) Mod 7)
End Function

Function UgeNr(Dato)
    UgeNr = Format(Dato, "ww", vbMonday, vbFirstFourDays)
End Function

Public Function ColoredCellsCount(rCountArea As Range, rCountColor As Range) As Double
    'Flemming Dahl, Januar 2002, fvd@smartoffice.dk
    Application.Volatile
    Dim dRetVal As Double
    Dim rCell As Range
    Dim iColor As Integer
    For Each rCell In rCountArea
        If rCell.Interior.ColorIndex = rCountColor.Interior.ColorIndex Then
            dRetVal = dRetVal + 1
        End If
    Next rCell
    ColoredCellsCount = dRetVal
    ' Clean up
    Set rCell = Nothing
End Function

Public Sub ColorWeekendsAndHolidaies(ByVal sSheetName As String)
    'Flemming Dahl, November 2005, fvd@smartoffice.dk
    ' Erstatning for betinget formatering
    Const sRNG_HEADER As String = "Header"
    Dim rCell As Range
    Dim rCurReg As Range
    Dim lCol As Long
    Dim bBlank As Boolean
   
    ' Find CurrentRegion med udgangspunkt i header rækken (6)
    Set rCurReg = Worksheets(sSheetName).Range(sRNG_HEADER).CurrentRegion
    ' Fjern header rækken fra rCurReg
    Set rCurReg = rCurReg.Offset(1, 0).Resize(rCurReg.Rows.Count - 1)
   
    For Each rCell In rCurReg.Columns(3).Cells
        bBlank = False
        If Not Trim$(rCell.Value) = "" Then
            If ErHelligdag(rCell.Value) Then
                ' Helligdag
                For lCol = -1 To rCurReg.Columns.Count - 4
                    rCell.Offset(0, lCol).Interior.ColorIndex = 15
                Next lCol
            Else
                bBlank = True
            End If
        Else
            bBlank = True
        End If
       
        If bBlank Then
            ' Arbejdsdag
            For lCol = -1 To rCurReg.Columns.Count - 4
                rCell.Offset(0, lCol).Interior.ColorIndex = xlNone
            Next lCol
        End If
    Next rCell
End Sub

********************

Ovenstående passer til en kalender (se dette spørgsmål: http://www.exp.dk/spm/667095 ) men i mit nye skema, så har jeg mine datoer i en række, i stedet for en kolonne. Datoerne strækker sig fra B2:AF2.

Det jeg gerne vil have i mit nye skema, er muligheden for at farvelægge helligdage/lørdage/søndage i 6 celler UNDER en dato (altså samme kolonne som datoen, f.eks. B3:B8). Faktisk skal det ske flere steder på arket, men det er altid i samme kolonne og altid seks celler under datoen, som skal farvelægges. Selve datoen skal ikke farvelægges.
Som sagt, så gør koden herover det, at den farvelægger selve datoen og så seks celler til højre for datoen (i samme række).

Ups... mon det er til at forstå?