Sub Comb()
Dim b%, s%, Nc&, i%, Tb(), j%, oS1 As Worksheet
Set oS1 = Worksheets("Cmb")
If WorksheetFunction.IsNumber(oS1.Cells(2, 1)) Then
b = oS1.Cells(2, 1)
Else
MsgBox "Nombre d'objets n'est pas un nombre"
Exit Sub
End If
If WorksheetFunction.IsNumber(oS1.Cells(4, 1)) Then
s = oS1.Cells(4, 1)
Else
MsgBox "Nombre d'emplacements n'est pas un nombre"
Exit Sub
End If
If b < s Then
MsgBox "Nombre d'objets < Nombre d'emplacements"
Exit Sub
End If
If oS1.Cells(Rows.Count, 1).End(xlUp).Row - 7 < b Then
MsgBox "Nombre d'objets > Liste d'Objets"
Exit Sub
End If
Application.ScreenUpdating = False
oS1.Range(oS1.Cells(2, 2), oS1.Cells(Rows.Count, Columns.Count)).ClearContents
oS1.Range(oS1.Cells(2, 2), oS1.Cells(Rows.Count, Columns.Count)).Interior.Pattern = xlNone
oS1.Range(oS1.Cells(1, 4), oS1.Cells(1, Columns.Count)).ClearContents
oS1.Range(oS1.Cells(1, 4), oS1.Cells(1, Columns.Count)).Interior.Pattern = xlNone
ReDim Tb(1 To b)
For i = 1 To b
Tb(i) = oS1.Cells(7 + i, 1)
Next i
Nc = Combin(b, s)
For i = 1 To s
oS1.Cells(2, 2 + i) = i
Next i
If Nc > 1 Then
For i = 1 To s
Select Case i
Case s
oS1.Cells(3, 2 + i).FormulaR1C1 = "=IF(R[-1]C=" & b & ",RC[-1]+1,R[-1]C+1)"
Case 1
oS1.Cells(3, 2 + i).FormulaR1C1 = "=IF(R[-1]C[1]=" & (b - s + 2) & _
",R[-1]C+1,R[-1]C)"
Case Else
oS1.Cells(3, 2 + i).FormulaR1C1 = "=IF(R[-1]C[1]=" & (b - s + 1 + i) _
& ",IF(R[-1]C=" & (b - s + i) & ",RC[-1]+1,R[-1]C+1),R[-1]C)"
End Select
Next i
oS1.Range(oS1.Cells(3, 3), oS1.Cells(3, 2 + s)).Copy Destination:=oS1.Range(oS1.Cells(3, 3), oS1.Cells(Nc + 1, 2 + s))
Application.CutCopyMode = False
oS1.Range(oS1.Cells(2, 3), oS1.Cells(Nc + 1, 2 + s)).Copy
oS1.Range(oS1.Cells(2, 3), oS1.Cells(Nc + 1, 2 + s)).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
For i = 1 To Nc
For j = 1 To s
oS1.Cells(i + 1, j + 2) = Tb(oS1.Cells(i + 1, j + 2))
Next j
Next i
oS1.Cells(1, 3).Copy
oS1.Range(oS1.Cells(2, 3), oS1.Cells(Nc + 1, 2 + s)).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
For i = 1 To Nc
oS1.Cells(i + 1, 2) = i
Next i
If b > 1 Then oS1.Cells(1, 3).AutoFill Destination:=oS1.Range(oS1.Cells(1, 3), oS1.Cells(1, 2 + s)), Type:=xlFillDefault
Application.ScreenUpdating = True
End Sub