tableaux croisés dynamiques sur un petit emploi du temps

'### Constantes à adapter ###
Const FEUILLE_LISTE As String = "Feuil1"
Const FEUILLE_FORMS As String = "Feuil2"
'############################

Sub EmploiDuTemps()
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim R2 As Range
Dim var1
Dim var2
Dim g&
Dim h&
Dim i&
Dim cpt&
Dim lig&
Dim A$
Dim T()
Set S = Sheets(FEUILLE_LISTE)
Set R = S.[a1].CurrentRegion
var1 = R
Set S2 = Sheets(FEUILLE_FORMS)
Set R2 = S2.[a1].CurrentRegion
var2 = R2
Set S = Sheets.Add(after:=Sheets(Sheets.Count))
Set R = S.[a1]
R2.Rows(1).Copy Destination:=R
For g& = 2 To UBound(var2, 1) Step 3
  If g& = 2 Then
    Set R = S.Range("a" & g& & "")
  Else
    Set R = S.Range("a" & S.UsedRange.Rows.Count + 2 & "")
  End If
  R2.Rows("" & g& & ":" & g& + 2 & "").Copy Destination:=R
  lig& = S.UsedRange.Rows.Count + 1
  For h& = 2 To UBound(var2, 2)
    cpt& = 0
    Erase T
    A$ = var2(g& + 2, h&)
    If A$ <> "" Then
      For i& = 2 To UBound(var1, 1)
        If var1(i&, 3) = 1 And var1(i&, 2) = A$ Then
          cpt& = cpt& + 1
          ReDim Preserve T(1 To 1, 1 To cpt&)
          T(1, cpt&) = var1(i&, 1)
        End If
      Next i&
    End If
    If cpt& > 0 Then
      Set R = S.Range(S.Cells(lig&, h&), S.Cells(lig& + cpt& - 1, h&))
      R = WorksheetFunction.Transpose(T)
    End If
  Next h&
Next g&
End Sub