Je suis toujours bloqué avec ma macro sur les combinaisons.
arnaud95000
Messages postés46Date d'inscriptionvendredi 3 août 2007StatutMembreDernière intervention18 décembre 2007
-
27 août 2007 à 12:05
arnaud95000
Messages postés46Date d'inscriptionvendredi 3 août 2007StatutMembreDernière intervention18 décembre 2007
-
27 août 2007 à 15:27
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
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
A voir également:
Je suis toujours bloqué avec ma macro sur les combinaisons.
mortalino
Messages postés6786Date d'inscriptionvendredi 16 décembre 2005StatutMembreDernière intervention21 décembre 201118 27 août 2007 à 12:12
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)
arnaud95000
Messages postés46Date d'inscriptionvendredi 3 août 2007StatutMembreDernière intervention18 décembre 2007 27 août 2007 à 15:27
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
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