Microsoft 365 Combinaisons d'objets

Option Explicit

Sub BiduleEtGroupe()
Dim tdata, t, tMax(), tRes
Dim i&, j&, k&, ng&, nBidMax&

'-----------------------------------  acquisition des données
With Sheets("data")
   If .FilterMode Then .ShowAllData
   tdata = .Range("a1").CurrentRegion.Formula
   With .Range("a1").CurrentRegion
      .Sort key1:=.Range("b1"), order1:=xlAscending, key2:=.Range("a1"), order2:=xlAscending, Header:=xlYes
      t = .Value
      .Value = tdata
   End With
End With

'-----------------------------------  tableau des groupes et de leurs bidules
'nombre de groupe avec pour chaque groupe son nombre de bidule
k = 0: j = 0
For i = 2 To UBound(t)
   If t(i, 2) <> t(i - 1, 2) Then
      k = k + 1
      ReDim Preserve tMax(1 To k)
      tMax(k) = 1    ' pour tenir compte d'une absence de bidule dans le groupe
   End If
   tMax(k) = tMax(k) + 1
Next i
ng = UBound(tMax)

'stockage du nom des groupes avec les noms des bidules associés
'stockage du nom des groupes avec les prix des bidules associés

For i = 1 To ng: nBidMax = IIf(tMax(i) > nBidMax, tMax(i), nBidMax): Next
ReDim nombid(1 To k, 1 To nBidMax + 1)
ReDim prixbid(1 To k, 1 To nBidMax + 1)
k = 0
For i = 2 To UBound(t)
   If t(i, 2) <> t(i - 1, 2) Then
      k = k + 1
      nombid(k, 1) = t(i, 2)
      prixbid(k, 1) = t(i, 2)
      nombid(k, 2) = t(i, 1)
      prixbid(k, 2) = t(i, 3)
      j = 2
   Else
      j = j + 1
      nombid(k, j) = t(i, 1)
      prixbid(k, j) = t(i, 3)
   End If
Next i

'toutes les combinaisons
tRes = TableauCombi(tMax)

'Affichage
With Sheets("Result")
   .Activate
   If .FilterMode Then .ShowAllData
   .UsedRange.Offset(1).Clear
   .Range("c1").Resize(, .Columns.Count - 2).ClearContents
   .Range("d1").Resize(, .Columns.Count - 3).Clear
   .Range("a2").Resize(UBound(tRes)).FormulaR1C1 = "=ROW()-1"
   .Range("a2").Resize(UBound(tRes)).Value = .Range("a2").Resize(UBound(tRes)).Value
   .Range("c1").Copy
   .Range("c1").Resize(, ng).PasteSpecial xlPasteFormats
   For i = 1 To UBound(nombid): Cells(1, 2 + i) = nombid(i, 1): Next
   'remplacer par les noms des objets et calculer le prix
   ReDim prix(1 To UBound(tRes), 1 To 1) As Currency
   For i = 1 To UBound(tRes)
      For j = 1 To ng
         prix(i, 1) = prix(i, 1) + prixbid(j, tRes(i, j) + 1)
         tRes(i, j) = nombid(j, tRes(i, j) + 1)
      Next j
   Next i
   .Range("c2").Resize(UBound(tRes), UBound(tRes, 2)) = tRes
   .Range("b2").Resize(UBound(tRes), 1) = prix
   .Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
   .Range("b2").Resize(UBound(tRes)).Style = "Currency"
   .Range("a2").Resize(UBound(tRes)).HorizontalAlignment = xlCenter
   .Range("a1").CurrentRegion.EntireColumn.AutoFit
End With
End Sub

Function TableauCombi(tm)
Dim p&, maxElem&, i&, nres&, Inc&

   'initialisation
   p = UBound(tm)    'nombre de Groupe
   maxElem = 1: For i = 1 To p: maxElem = maxElem * tm(i): Next 'nombre de combinaisons au final
   ReDim Combi(1 To p)    'tableau de la combinaison en cours d'édition
   ReDim res(1 To maxElem, 1 To p) 'tableau de toutes les combinaisons
   'la première combinaison est (1, 1 , 1, ... , 1)
   For i = 1 To p: Combi(i) = 1: Next
   'stockage de la première combinaison
   nres = nres + 1: For i = 1 To p: res(nres, i) = Combi(i): Next
   'boucle pour les autres combi
   Inc = p     'la colonne à incrémenter est la dernière
   Do
      If Combi(Inc) + 1 > tm(Inc) Then
         'si l'élément de combi en colonne Inc incrémenté de 1
         'dépasse le maximun autorisé, on décrémente Inc
         Inc = Inc - 1
         'si Inc arrive à zéro, on est à la fin de la boucle
         If Inc = 0 Then Exit Do
      Else
         'si l'élément de combi en colonne Inc incrémenté de 1
         'ne dépasse pas le maximun autorisé, on incrémente cet élément
         Combi(Inc) = Combi(Inc) + 1
         'les éléments suivants sont chacun égaux à 1
         For i = Inc + 1 To p: Combi(i) = 1: Next
         'on stocke la nouvelle combinaison
         nres = nres + 1: For i = 1 To p: res(nres, i) = Combi(i): Next
         Inc = p
      End If
   Loop
   TableauCombi = res
End Function