Bonjour.
 
J'ai un souci sous VBA du fait du manque de place. Ma macro fait toutes les combinaisons possibles sauf qu'à partir d'un certain niveau d'éléments nous ne pouvons plus...par exemple si je prends 10 éléments parmi 20 excel beug. J'aurai donc souhaité ajouté une feuille à chaque fois qu'excel arrive à la dernière ligne, de manière à ce que j'ai toutes les combinaisons possibles
Merci beaucoup de votre aide.
 
Voici mon code:
 
  '1. En A1, écrire c ou p ; (Combinaison ou Permutation)
  '2. En A2, écrire la valeur de R ;
  '3. Sous A2, écrire la liste des N éléments ;
  '4. Sélectionner A1 et activer la procédure.
 
'Exemple:
'A1 c
'A2 3
'A3 1
'A4 2
'A5 Excel
'A6 4
'A7 *
'A8 6
'
'La procédure donne alors la liste de toutes les combinaisons
'possibles de 3 éléments choisis parmi 6.
 
 
Option Explicit
 
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
 
                              'procédure1
                               
 
 
Sub ListPermutations()
Worksheets("combinaisons" ).Select
Range("A1" ).Select
  Dim Rng As Range
  Dim PopSize As Integer
  Dim SetSize As Integer
  Dim Which As String
  Dim N As Double
  Dim message As Integer
  Dim nom As String
  Dim sh As Worksheet, trouvé As Boolean
  trouvé = False
   
  message = InputBox("nombre d'éléments p parmi N?", "Combinaison de p éléments parmi N", 3)
  Range("A2" ) = message
   
  Const BufferSize As Long = 7202
 
  Set Rng = Selection.Columns(1).Cells
  If Rng.Cells.Count = 1 Then
    Set Rng = Range(Rng, Rng.End(xlDown))
  End If
 
  PopSize = Rng.Cells.Count - 2
  If PopSize < 2 Then GoTo DataError
 
  SetSize = Rng.Cells(2).Value
  If SetSize > PopSize Then GoTo DataError
 
  Which = UCase$(Rng.Cells(1).Value)
  Select Case Which
  Case "C"
    N = Application.WorksheetFunction.Combin(PopSize, SetSize)
  Case "P"
    N = Application.WorksheetFunction.Permut(PopSize, SetSize)
  Case Else
    GoTo DataError
  End Select
  If N > Cells.Count Then GoTo DataError
 
  Application.ScreenUpdating = False
 
 
   
  nom = "résultats"
  Set Results = Worksheets.Add
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets("résultats" ).Delete
  Application.DisplayAlerts = True
  Results.Name = nom
 
  vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
  ReDim Buffer(1 To BufferSize) As String
  BufferPtr = 0
 
  If Which = "C" Then
    AddCombination PopSize, SetSize
  Else
    AddPermutation PopSize, SetSize
  End If
  vAllItems = 0
 
  Application.ScreenUpdating = True
  Exit Sub
 
DataError:
  If N = 0 Then
    Which = "Enter your data in a vertical range of at least 4 cells. " _
      & String$(2, 10) _
      & "Top cell must contain the letter C or P, 2nd cell is the number" _
      & "of items in a subset, the cells below are the values from which" _
      & "the subset is to be chosen."
  Else
    Which = "This requires " & Format$(N, "#,##0" ) & _
      " cells, more than are available on the worksheet!"
  End If
  MsgBox Which, vbOKOnly, "DATA ERROR"
  Exit Sub
End Sub
 
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0)
 
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Static Used() As Integer
  Dim i As Integer
 
  If PopSize <> 0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    ReDim Used(1 To iPopSize) As Integer
    NextMember = 1
  End If
 
  For i = 1 To iPopSize
    If Used(i) = 0 Then
      SetMembers(NextMember) = i
      If NextMember <> iSetSize Then
        Used(i) = True
        AddPermutation , , NextMember + 1
        Used(i) = False
      Else
        SavePermutation SetMembers()
      End If
    End If
  Next i
 
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
    Erase Used
  End If
 
End Sub  'AddPermutation
 
Private Sub AddCombination(Optional PopSize As Integer = 0, _
  Optional SetSize As Integer = 0, _
  Optional NextMember As Integer = 0, _
  Optional NextItem As Integer = 0)
 
  Static iPopSize As Integer
  Static iSetSize As Integer
  Static SetMembers() As Integer
  Dim i As Integer
 
  If PopSize <> 0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    NextMember = 1
    NextItem = 1
  End If
 
  For i = NextItem To iPopSize
    SetMembers(NextMember) = i
    If NextMember <> iSetSize Then
      AddCombination , , NextMember + 1, i + 1
    Else
      SavePermutation SetMembers()
    End If
  Next i
 
  If NextMember = 1 Then
    SavePermutation SetMembers(), True
    Erase SetMembers
  End If
 
End Sub  'AddCombination
 
Private Sub SavePermutation(ItemsChosen() As Integer, _
  Optional FlushBuffer As Boolean = False)
 
  Dim i As Integer, sValue As String
  Dim j As Integer, w As Long, k As Long
  Dim message As Integer
  Dim ChaineASeparer
 
   
  Static RowNum As Long, ColNum As Long
   
  If RowNum = 0 Then RowNum = 1
  If ColNum = 0 Then ColNum = 1
 
  If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
    If BufferPtr > 0 Then
       
      If (RowNum + BufferPtr - 1) > Rows.Count Then
        RowNum = 1
        ColNum = ColNum + 1
        If ColNum > 256 Then Exit Sub
      End If
 
    '
    Dim li_compteur As Long, li_compt_feuilles As Long
    For k = 1 To BufferPtr
      ChaineASeparer = Split(Buffer(k), "," )
        If (RowNum + BufferPtr - 1) > Rows.Count Then Stop
        For w = 0 To UBound(ChaineASeparer)
           
          li_compteur = li_compteur + 1
          li_compt_feuilles = 1
          If (li_compteur Mod 10000) = 0 Then
            li_compt_feuilles = li_compt_feuilles + 1
            Set Results = Worksheets.Add
            Results.Name = "Res" & li_compt_feuilles
            k = 1
            Stop
          End If
          Results.Cells(RowNum + k - 1, ColNum + w).Value = ChaineASeparer(w)
      Next
    Next
      'Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
        = Application.WorksheetFunction.Transpose(Buffer())
      'RowNum = RowNum + BufferPtr
    End If
 
    BufferPtr = 0
    If FlushBuffer = True Then
      Erase Buffer
      RowNum = 0
      ColNum = 0
      Exit Sub
    Else
      ReDim Buffer(1 To UBound(Buffer))
    End If
 
  End If
  'construct the next set
  For i = 1 To UBound(ItemsChosen)
  j = 1
  sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
  'and save it in the buffer
  Next i
  BufferPtr = BufferPtr + 1
  Buffer(BufferPtr) = Mid$(sValue, 3)
  End Sub
 
Merci