Je suis toujours bloqué avec ma macro sur les combinaisons.

Question

Salut à tous je despère car je n'arrive pas trouver la réponse à mon problème. En fait j'ai uen macro qui réalise des combinaisons, et donc le nombre de combinaisons augmentent rapidement avec le nombre de p élément parmi les N. Ce que je voudrais c'est qu'escel ajoute une feuille lorsqu'il n'a plus de place sur la feuille pour mettre les résultats. Ci joint la macro et merci d'avance pour votre aide. '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'actifs?", "Combinaison des actifs", 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) Do While (li_compteur Mod 10000) = 0 li_compt_feuilles = li_compt_feuilles + 1 Set Results = Worksheets.Add Results.Name = "Res" & li_compt_feuilles li_compteur = li_compteur + 1 li_compt_feuilles = 1 Loop k = 1 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

mortalino · Answer

bah en fait on répond pas car il y a trop de code et nous n'avons pas ton classeur sous la main (et donc nous ne connaissons pas les données étant dedans).
Mais si c'est toi qui à tout codé, il ne devrait pas y avoir de problème^^

Une seule solution : Soit tu as du temps à perdre et tu exécutes ton code en mode Pas à pas, afin de déceler à quel moment (et surtout à quel endroit) tu arrives à la ligne 65536 de ton classeur, et de là il faut faire une fonction pour créer un nouvel onglet.
Si t'es moins patient, lance ton code, et dès que t'as l'erreur, appuie sur débogage pour voir où se trouve l'erreur.
Tu sauras que c'est à cet endroit qu'il faut gérer l'erreur et rajouter l'onglet.
Rien que ça, ça devrait t'aiguiller pas mal. Et si tu galères, montre nous à quelle ligne ça plante et quel est le message d'erreur (dep. capacités, certainement)

@++ 

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA

arnaud95000 · Answer

Non biensûr elle n'est pas de moi, je suis débutant en VBA et si elle etait de moi je pense que j'aurai reussi à résoudre ce problème.lol.Donc voici mes données qui sont dans l'onglet combinaisons. En noir le tableur excel, en rose les données que je rentre(c pour combinaisons, 10 pour dire que j'en veux 10 parmi les 20 lettres et ensuite les lettres qui me serviront a faire les combinaisons. (onglet combinaisons) A B C D E F G H I J K L M N 1 c 2 10 3 A 4 B 5 C 6 D 7 E 8 F 9 G 10 H 11 I 12 J 13 K 14 L 15 M 16 N 17 O 18 P 19 Q 20 R 21 S 22 T les résultats suite au lancement de la macro A B C D E F G H I J K L M N O P Q R 1 E G H I K L N P S T 2 E G H I K L N Q R S 3 4 ........................................................................................................................................................ 7200 E G H I K L N O S T 7201 E G H I K L N P Q R 7202 E G H I K L N P Q S J'ai mis les endroits qu'il faut modifier pour que çà marche mais après je sais pas comment je peux les modifier. 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'actifs?", "Combinaison des actifs", 3) Range("A2") = message Const BufferSize As Long = 7202 (La c'est le nombre de ligne ou ça stop sur la 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ée de 7202 c'est à dire If Used(i) = 0 Then en feuille 2 que i aille de 7202 à 14404 en feuille 3 de 14404 à 21606 ect... 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 7202 et que çà reparte du début avec l'augmentation des 7202 à chauqe 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 Merci

Je suis toujours bloqué avec ma macro sur les combinaisons.

2 réponses

Votre réponse

Discussions similaires