VBA : parcours en cascade

'### Constantes à adapter ###
Const FEUILLE_CHOIX As String = "CHOIX"
Const FEUILLE_LISTES As String = "LISTES"
Const SEPARATEUR As String = "_"
'############################

'/// Portée au niveau module ///
Dim R1 As Range
Dim R2 As Range
Dim C1 As Range
Dim C2 As Range
Dim Result()
'///////////////////////////////

Sub aa()
Dim S As Worksheet
Dim R As Range
Dim var
Dim Retour
Dim i&
Dim j&
Dim k&
Dim Lig&
Dim A$
Dim T()
'---
Set S = Sheets(FEUILLE_CHOIX)
Set R = S.UsedRange
var = R
Lig& = 1
'---
For i& = 2 To UBound(var, 1)
  A$ = ""
  For j& = 2 To UBound(var, 2)
    If var(i&, j&) = "x" Then
      A$ = A$ & var(1, j&) & SEPARATEUR
    End If
  Next j&
  A$ = Mid(A$, 1, Len(A$) - 1)
  '---
  Retour = GetCombinaisons(A$)
  ReDim Preserve T(1 To 1, 1 To Lig& + UBound(Retour) - 1)
  For k& = 1 To UBound(Retour)
    T(1, Lig&) = Retour(k&)
    Lig& = Lig& + 1
  Next k&
Next i&
'--- Inscription ---
Set S = Sheets.Add
S.Range("a1:a" & UBound(T, 2) & "") = Application.WorksheetFunction.Transpose(T)
End Sub

Private Function GetCombinaisons(A$) As Variant
Dim tempo
Dim i&
Dim k&
Dim cpt&
Dim T()
Dim T2()
'---
ReDim T(0)
tempo = Split(A$, SEPARATEUR)
'---
If UBound(tempo) = 0 Then
  Set R1 = GetRange(A$)
  ReDim T(1 To R1.Rows.Count)
  For Each C1 In R1
    cpt& = cpt& + 1
    T(cpt&) = C1
  Next C1
Else
  For k& = UBound(tempo) To LBound(tempo) Step -1
    If UBound(T) = 0 Then
      Set R2 = GetRange(tempo(k&))
      Set R1 = GetRange(tempo(k& - 1))
      ReDim T(1 To R2.Rows.Count * R1.Rows.Count)
      For Each C1 In R1
        For Each C2 In R2
          cpt& = cpt& + 1
          T(cpt&) = C1 & SEPARATEUR & C2
        Next C2
      Next C1
      k& = k& - 1
    Else
      T2 = T
      Set R2 = GetRange(tempo(k&))
      ReDim T(1 To UBound(T) * R2.Rows.Count)
      cpt& = 0
      For Each C2 In R2
        For i& = 1 To UBound(T2)
          cpt& = cpt& + 1
          T(cpt&) = C2 & SEPARATEUR & T2(i&)
        Next i&
      Next C2
    End If
  Next k&
End If
'---
GetCombinaisons = T
End Function

Private Function GetRange(ByVal Titre As String) As Range
Dim S As Worksheet
Dim R As Range
Dim var
Dim j&
Dim LastLig&
'---
Set S = Sheets(FEUILLE_LISTES)
Set R = S.UsedRange
var = R
For j& = 1 To UBound(var, 2)
  If var(1, j&) = Titre Then
    LastLig& = S.Cells(Application.Cells.Rows.Count, j&).End(xlUp).Row
    Set R = S.Range(S.Cells(2, j&), S.Cells(LastLig&, j&))
    Exit For
  End If
Next j&
Set GetRange = R
End Function