XL 2016 Tableau horaire...formules? VBA? formes conditionnelle...à l'aide

Option Explicit

Dim ct As Byte

Private Function gcf(typ$) As Long
  Select Case typ
    Case "A1": gcf = 15773696               'bleu clair
    Case "A2": gcf = 65535                  'jaune
    Case "D1": gcf = 49407                  'orange
    Case "D2": gcf = 255: ct = 2            'rouge
    Case "Special": gcf = 10498160: ct = 2  'violet
    Case "Staff": gcf = 5287936             'vert
  End Select
End Function

Sub Essai()
  If ActiveSheet.Name <> "Airport transfers" Then Exit Sub
  Dim n1&
  With ActiveSheet.ListObjects("Tableau1")
    If .DataBodyRange Is Nothing Then Exit Sub
    n1 = .ListRows.Count: If n1 = 0 Then Exit Sub
  End With
  Dim sh As Worksheet, n2&: Application.ScreenUpdating = 0
  Set sh = Worksheets("Mercredi"): n1 = n1 + 1
  n2 = sh.Cells(Rows.Count, 2).End(3).Row
  If n2 > 3 Then
    With sh.Range("F4:BB" & n2)
      .Interior.ColorIndex = -4142: .Font.Bold = 0
      .Font.ColorIndex = -4105: .ClearContents
    End With
  End If
  Dim cel As Range, dt As Date, h1 As Date, h2 As Date
  Dim drv$, tsk%, cf&, clt$, a%, b%, c%, d%, i&, j&
  For i = 2 To n1
    With Cells(i, 1)
      drv = .Offset(, 7)
      If drv <> "" Then
        Set cel = sh.Columns(2).Find(drv, , -4163, 1, 1)
        If Not cel Is Nothing Then
          tsk = .Value: ct = 1: cf = gcf(.Offset(, 1)): clt = .Offset(, 12): j = cel.Row
          dt = .Offset(, 2): h1 = Hour(.Offset(, 3)): h2 = Hour(.Offset(, 4)): a = 6
          Do
            With sh.Cells(3, a)
              b = a + .MergeArea.Columns.Count
              If IsEmpty(.Value) Then Exit Do
              If .Value = dt Then
                b = b - 1
                For c = a To b
                  If Hour(sh.Cells(2, c)) = h1 Then
                    With sh.Cells(j, c)
                      .Font.ColorIndex = ct: .Value = clt & " #" & tsk: d = c
                      Do While Not IsEmpty(sh.Cells(2, d))
                        If Hour(sh.Cells(2, d)) = h2 Then Exit Do
                        sh.Cells(j, d).Interior.Color = cf: d = d + 1
                      Loop
                    End With
                    Exit Do
                  End If
                Next c
                Exit Do
              Else
                a = b
              End If
            End With
          Loop
        End If
      End If
    End With
  Next i
  sh.Select
End Sub