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

Signaler
Messages postés
46
Date d'inscription
vendredi 3 août 2007
Statut
Membre
Dernière intervention
18 décembre 2007
-
Messages postés
46
Date d'inscription
vendredi 3 août 2007
Statut
Membre
Dernière intervention
18 décembre 2007
-
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

2 réponses

Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
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
Messages postés
46
Date d'inscription
vendredi 3 août 2007
Statut
Membre
Dernière intervention
18 décembre 2007

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