Microsoft 365 Croiser toutes les associations possibles de cultures positives

[carlos]

Bo

 

[carlos]

Avez vous trouvé une solution à mon problème?
De mon coté je galère avec les boucles et les conditions à répétitions.
Je bloque au Niveau 3 des boucles car il y a trop de paramètres à gérer.
Ce n'est peut etre pas possible car trop complexe?

 

[carlos]

Bonjour,
Ce code fonctionne avec des listbox en cascade mais il est tres lourd.
Comment pourrait on améliorer la durée d’exécution?
Bonne journée à tous
Dim N1 As Byte
Dim N2 As Byte
Dim N3 As Byte
Dim N4 As Byte
Dim N5 As Byte
Dim N6 As Byte
Dim Associe1 As String
Dim Associe2 As String
Dim Associe3 As String
Dim Associe4 As String
Dim Associe5 As String
Dim Associe6 As String
Dim Associe As String
Dim Ligne As Integer
Application.ScreenUpdating = False
Feuil4.Range("B1:BZ10000").ClearContents
For N1 = 1 To ListBox6.ListCount
On Error Resume Next
ListBox6.ListIndex = N1 - 1
If ListBox6.ListCount > 0 Then Associe1 = ListBox6.List(N1 - 1)
For N2 = 1 To ListBox7.ListCount
ListBox7.ListIndex = N2 - 1
If ListBox7.ListCount > 0 Then Associe2 = ListBox7.List(N2 - 1)
If ListBox8.ListCount = 0 Then
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1 + 1) = Associe1 & "/" & Associe2
ListBox12.AddItem Associe1 & "/" & Associe2
If N2 = ListBox7.ListCount Then GoTo suite1 Else GoTo suite2
End If
For N3 = 1 To ListBox8.ListCount
ListBox8.ListIndex = N3 - 1
If ListBox8.ListCount > 0 Then Associe3 = ListBox8.List(N3 - 1)
If ListBox9.ListCount = 0 Then
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1) = Associe1 & "/" & Associe2 & "/" & Associe3
ListBox12.AddItem Associe1 & "/" & Associe2 & "/" & Associe3
If N3 = ListBox8.ListCount Then GoTo suite2 Else GoTo suite3
End If
For N4 = 1 To ListBox9.ListCount
ListBox9.ListIndex = N4 - 1
If ListBox9.ListCount > 0 Then Associe4 = ListBox9.List(N4 - 1)
If ListBox10.ListCount = 0 Then
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1) = Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4
ListBox12.AddItem Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4
If N4 = ListBox9.ListCount Then GoTo suite3 Else GoTo suite4
End If
For N5 = 1 To ListBox10.ListCount
ListBox10.ListIndex = N5 - 1
If ListBox10.ListCount > 0 Then Associe5 = ListBox10.List(N5 - 1)
If ListBox10.ListCount = 0 Then
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1) = Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4 ' & "/" & Associe5
ListBox12.AddItem Associe1 & "/" & Associe2 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4
If N5 = ListBox10.ListCount Then GoTo suite4 Else GoTo suite5
Else
If ListBox11.ListCount = 0 Then
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1) = Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4 & "/" & Associe5
ListBox12.AddItem Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4 & "/" & Associe5
If N5 = ListBox10.ListCount Then GoTo suite4 Else GoTo suite5
End If
For N6 = 1 To ListBox11.ListCount
ListBox11.ListIndex = N6 - 1
Associe6 = ListBox11.List(N6 - 1)
Feuil4.Range("B" & Feuil4.Range("B6500").End(xlUp).Row + 1) = Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4 & "/" & Associe5 & "/" & Associe6
ListBox12.AddItem Associe1 & "/" & Associe2 & "/" & Associe3 & "/" & Associe4 & "/" & Associe5 & "/" & Associe6
Next N6
End If
suite5:
Next N5
suite4:
Next N4
suite3:
Next N3
suite2:
Next N2
suite1:
Next N1
Unload Me
Feuil4.Select
Application.ScreenUpdating = True

Voici le code qui alimente la listbox suivante, ici la Listbox7 qui alimente la listbox8 :

Private Sub ListBox7_Click()
Dim I As Byte
Dim tabN2(40, 1)
Dim K As Byte
Dim Foundcell As Range
K = 0
Dim p As Byte

For p = 8 To 11
Controls("Listbox" & p).Clear
Next p

For I = 1 To 40
If Cells(ListBox7.List(ListBox7.ListIndex, 1), 6 + I).Value = "" Then GoTo Suite
If Cells(ListBox7.List(ListBox7.ListIndex, 1), 6 + I).Value = Label5.Caption Then GoTo suite1
If Cells(ListBox7.List(ListBox7.ListIndex, 1), 6 + I).Interior.Color = vbGreen Then
Set Foundcell = Range("A2:A" & Range("A6500").End(xlUp).Row).Find(what:=Cells(ListBox7.List(ListBox7.ListIndex, 1), 6 + I).Value, LookAt:=xlWhole)
If Not Foundcell Is Nothing Then
K = K + 1
tabN2(K, 0) = Cells(ListBox7.List(ListBox7.ListIndex, 1), 6 + I).Value
tabN2(K, 1) = Foundcell.Row
End If
End If
suite1:
Next I
Suite:
For K = 1 To K
For Z = 1 To ListBox7.ListCount
If tabN2(K, 0) = ListBox7.List(Z - 1) Then
ListBox8.AddItem tabN2(K, 0)
ListBox8.List(ListBox8.ListCount - 1, 1) = tabN2(K, 1)
End If
Next Z
Next K
Label6.Caption = ListBox7.Value
End Sub

 

[pierrejean]

Re
Je peux tenter d'adapter ton code avec des tableaux en lieu et place des listbox
Pour ceci peux-tu me parler (en pur gaulois) de l'algorithme sous-jacent ?
Éventuellement un commentaire des macros pourrait m’éclairer

 

[carlos]

Bonjour PierreJean
Merci de reprendre ce post en main.
Je vais essayer de parler en pur Gaulois et le mieux est d’utiliser le fichier joint et de suivre les étapes des clics sur les listbox pour mieux comprendre.

Voici le fichier que j'ai créé pour construire les différentes possibilités d'associations de plantes entre elles.
L'onglet "Aime Deteste" permet d'associer les legumes qui vont bien avec la colonne 1. En vert ce qu'il aime et en rouge ce qu'il deteste.
Etape 1 : L'onglet "Resulat Global" récupère tous les plants qui s'aiment et qui peuvent se cultiver ensemble.
J'ai 5588 possibiltés.
Etape 2 : L'onglet "Reduire" permet de reduire les resultats de 5588 de l'onglet "Résultat Global"à 213 possibilités. Travail réussi par le site ExcelDownload.
Le fichier joint m'a permis de faire l'étape 1. En ouvrant ce fichier il faut cliquer sur le bouton rouge"Associer" pour ouvre le userform. C'est dans l''onglet2 du Userform ("Créer les planches") que tout se passe.
Si je veux connaitre toutes les plants qui aiment l'aubergine, je clique dessus sur la première listbox.. J'ai 11 plants qui l'aiment. Ceux ci apparaissent alors sur la seconde listbox. De Capucine à Thym. Dans ces 11, la carotte aime l’aubergine. Le Haricot aime l’aubergine . Mais est ce que je pourrais mettre de l’aubergine, de la carotte et des haricots ensemble dans le même bac de mon potager . La carotte aime t’elle les haricots ?
En cliquant sur Carotte,(Deuxième listbox), les haricot s’affiche en 3ieme listbox donc la carotte aime les haricots.

Ensuite les Haricots aiment les laitues et les radis . Et ainsi de suite jusqu’épuisement des associations.

Pour résumer nous pouvons associer : Aubergine/Carotte/Haricot/Laitue/Radis
Je peux passer en revue, un par un, tous les éléments de mes plants par ce moyen.

Pour récapituler dans une colonne toutes les associations j’ai utiliser la macro jointe au post précédent et qui se trouve derrière le bouton « Exporter toutes les associations possibles ». Celle-ci simule le clic dans chacune des listbox et pour tous les Items (C’est pour cela que c’est très long »
Je suis dispo pour donner plus d'explication.
Merci et bonne journée
Carlos

 

[chris]

Dire que cela se fait en quelques clics sur PowerQuery...

 

[carlos]

@chris,
Bonjour, je comprends effectivement que cela puisse se faire plus rapidement avec PowerQuery plutôt qu'en VBA mais comme ce fichier devrait être automatisé pour pouvoir être diffusé auprès de quelques jardiniers, j'ai préféré prendre en vba. Je me suis peut être trompé et j'en suis désolé.
Bonne soirée.

 

[Dranreb]

Bonsoir.
Je crois que je tiens toutes les associations d'au moins deux plantes mutuellement supportées.
À vérifier.
Mais je n'ai pas trouvé comment éliminer les petites associations intégralement contenues dans de plus grandes.

 

[carlos]

Bonjour Dranreb,
Super, je n'ai pas tout vérifier mais cela me parait correct.
J'ai essayé de l'intégré au code de @job75 pour réduire la base mais effectivement cela ne le réduit pas et je ne comprends pas pourquoi. Voir en PJ.
Merci beaucoup pour cette grande avancée et bonne journée
Carlos

 

[carlos]

Bonjour Dranreb, j'ai testé ta proposition et réduit les chaines incorporés par la methode de Job75 (https://www.excel-downloads.com/thr...pourra-supprimer-cette-chaine.20048012/page-2) et le résultat est parfait.
Tu as parfaitement raccourci le temps d’exécution de ma macro.
Voi en PJ le résultat.
Je suis super content.
Merci et bonne journée

 

[Dranreb]

Bonjour.
Ah ça, je n'avais pas pensé à utiliser la fonction NB.SI. D'ailleurs je ne suis même pas sûr que je savais qu'elle acceptait le jocker "*" dans le texte à rechercher.
Cela dit si j'avais su que vous le vouliez au final sous forme de textes séparés par des "/" je l'aurais directement produit sous cette forme. Mais des racourcis son possibles pour l'ensemble, ne serait-ce que parce que les textes sont déjà partout dans le même ordre donc le tri est inutile.
Je joins le classeur qui fait tout en une fois

 

[carlos]

Bonjour Dranreb
Super bien et propre.
J'avais déjà incorporé ta macro avec celle de Job75 mais comme d'hab' c’était pas aussi propre que ce que vous faites.
Ça marche impeccablement bien et très rapidement.
Merci beaucoup beaucoup.
Je continue a avancer dans mon projet et solliciterais certainement encore une fois vos compétences.
Bonne journée

 

[Dranreb]

Remarque:
Je trouve quand même un peu curieux, si toutefois c'est bien comme ça qu'il fallait l'interpréter, que les associations 2 à 2 spécifiées dans la feuille "Associations positives" pourraient ne pas être automatiquement réciproques. On peut simplifier un peu si elle doivent toujours être considérées comme telles même en cas d'oubli dans un des deux sens: le petit tableau TAiméPar n'aurait plus lieu d'être.

 

[carlos]

Je ne comprends pas tres bien ce que tu veux dire?
Pour la premier ligne par exemple:

Absynthe-Armoise

Chou

Laitue

Poireau

Pois

On ne peut pas planter les 5 plantes ensemble car le poireau n'est pas apprécié par exemple par l'ail et l'ail n'aime pas le poireau.
Peux tu m"en dire un peu plus car je fais peut etre fausse route?

 

[Dranreb]

Non, non, ce n'est pas ça :
j'ai bien dit 2 à 2
Le chou et la laitue seraient considérés compatibles puisqu'on a dit que la laitue pouvait être plantée avec le chou, même si on aurait oublié de dire aussi que le chou pouvait être planté avec la laitue. Actuellement ce n'est pas le cas, mais c'était peut être inutile.

 

[carlos]

Dans cette chaine :

Absynthe-Armoise/Chou/Laitue/Pois Je pourrais faire une planche avec toutes les combinaisons possibles cad que tous ces légumes entres eux 5 sont Compatibles : Absynthe-Armoise/Chou Chou/Laitue/Pois Chou/Laitue etc... Idem pour les suivants. Le fait de les avoir mis ensemble ne m'impose pas qu'ils soient toujours à 5 (dans cet exemple).