Bonjour j'ai un souci sous VBA en faitj'ai une macro qui tourne pas mal et qui determine toutes les combinaisons de p éléments parmi N. Le souci c'est que les résultats arrivent très vite à leur termes.  
En fait l'idéal serait d'ajouter une feuille qd l'autre est terminée et qu'automatiquement la macro soit relancée avec les modifications notées entre crochets sur la macro suivante.
merci
 
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 des p éléments parmi N", 3)
Range("A2" ) = message
 
 
 
 
[Const BufferSize As Long = 65536 (La c'est le nombre de lignes ou ça stope les résultats sur une feuille) 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 Là il faudrait il faudrait que sur chaque nouvelle feuille ajoutée le i soit augmenté de 65536 c'est à dire en feuille 2 for i=65536 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  
 
For k = 1 To BufferPtr
ChaineASeparer = Split(Buffer(k), "," )
 
 
 
 
[If (RowNum + BufferPtr - 1) > Rows.Count Then Stop je pense que c'est ici qu'il faut mettre une condition d'ajout de feuille si çà dépasse 65536 et que çà reparte du début avec l'augmentation des 65536 à chaque feuille ajoutée.]
 
 
 
 
For w = 0 To UBound(ChaineASeparer)
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