VBA ; recherche de valeurs mini sur une plage de façon dynamique

Raka

XLDnaute Occasionnel
Bonjour.

Je recrée un sujet parce que ce que je recherche là est déjà un peu trop éloigné du précédent, qui, en soi, est résolu.

Donc voici ce que j'ai :

Un problème de codage que je n'arrive pas à faire tourner en ma faveur.

Je dispose d'un tableau aux données variables selon l'implémentation d'un json.

Mon but : trouver le nombre MAXMUM de cellules dont les valeurs additionnées permettent d'arriver à une valeur entrée manuellement. Donc, trouver les valeurs les plus faibles.

Handicap : une cellule ne peut pas être sélectionnée si celle de gauche ne l'est pas avant.

Mon idée : créer un code qui va chercher les valeurs les plus faibles et non-colorées dans le tableau, regarder si chacune d'entre elle, additionnée au total des précédentes, dépasse la valeur manuelle à ne pas dépasser. Si elle ne dépasse pas, verdir la case et recommencer, sinon la rougir et fin du truc.

J'ai ce code, qui fonctionne : on entre un nombre en B2, et il cherche la plus petite valeur, colonne par colonne, et les additionne jusqu'à atteindre la valeur B2 sans la dépasser. Les cellules non-atteignables (parce que valeur donnée en B2 serait dépassée) se colorent ensuite en rouge.

VB:
Sub Bouton1_Cliquer()

Dim valeur As Integer
Dim Somme As Long

valeur = 0
Somme = Range("B2").Value

Dim i As Integer
Dim j As Integer
Dim TempSomme As Long


Min = Cells(2, 2).Value
TempSomme = 0

For j = 7 To 55
For i = 2 To 354
   If IsNumeric(Cells(i, j).Value) Then
    If Not IsNumeric(Cells(i, j - 1).Value) Or Cells(i, j - 1).Interior.Color = RGB(35, 233, 144) Then
        If Cells(i, j).Value <> 0 Then
            If Cells(i, j).Value + TempSomme < Min Then
    '           Min = Cells(i, j).Value
            TempSomme = TempSomme + Cells(i, j).Value
            Cells(i, j).Interior.Color = RGB(35, 233, 144)
            NbLvl = NbLvl + 1
            Else
             Cells(i, j).Interior.Color = RGB(231, 62, 1)
            End If
        End If
    End If
   End If
Next i
Next j

Cells(12, 2).Value = NbLvl
Cells(24, 2).Value = TempSomme

End Sub

La ligne If Not est là pour s'assurer que les valeurs à droite des valeurs rouges ne soient pas sélectionnées tout en s'assurant que la valeur la plus à gauche du tableau puisse l'être (non visible sur ce screen mais elle se trouve collée à droite d'une colonne contenant des noms, donc non numériques).

Mais du coup, je crois que ma méthode d'approche n'est pas la bonne. Le but étant de toujours sélectionner les cases contenant la valeur la plus faible, et sachant que sur une même colonne, il peut y avoir des valeurs aléatoires, je crois que je n'ai pas pris le bon chemin... En effet :

1595762163197.png

La macro choisit la case à 4.000 avant de choisir celles à 2000, ce qui n'est pas bon du tout.

Plutôt que de passer le tableau ligne par ligne, colonne par colonne comme je l'ai fait, n'existe-t-il pas un moyen simple de faire un parcours d'arbre ? Ou si c'est trop compliqué en VBA, faire en sorte que la macro parcoure le tableau de la sorte :

Il faudrait que je trouve un moyen de remplacer "regarder colonne" par "regarder la valeur numérique non-colorée le plus à gauche de chaque ligne." Dans la plage couverte par i:j bien sûr.

Cette méthode aurait le mérite de comparer les cellules 2000 avec la cellule 4000, toutes trois "les plus à gauche", et de colorer les 2000 avant la 4000, logique que je cherche.

Pour donner un exemple concret :

Dans le tableau ci-dessus, la première occurrence de la recherche (sur tableau totalement blanc donc) devrait comparer les valeurs 3000, 80, 2000 et 4000. Elle va donc colorer 80, puis comparer les valeurs 3000, 120, 2000 et 4000. Colorer 120, etc...

Est-ce simple à faire ?
 
Dernière édition:

Raka

XLDnaute Occasionnel
OOh. Ca rame pas mal :D
Mais ça m'a l'air d'être ça... Je fais quelques tests un peu plus poussés pour vérifier mais...
Du coup, j'attends également la proposition d'Eric pour voir si ça "rame" un peu moins quand on clique sur la macro ^^
 

Raka

XLDnaute Occasionnel
Et effectivement, ça m'a l'air d'être totalement ça sur plusieurs tests.
Je te remercie grandement ! J'attends l'autre proposition aussi du coup :p Par curiosité, et parce que ça me permet d'apprendre (quoi que dans cette macro, certaines chose sont largement au-delà de ma compréhension, donc va falloir que je l'épluche pas à pas, parce que je veux comprendre.)

Sinon, pas de cases rouges pour les limites "non atteintes", un peu dommage, mais je peux m'en passer.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,
OOh. Ca rame pas mal
Je n'ai pas songé à la rapidité mais à essayer de comprendre et déjà d'arriver au but. C'est du brut de décoffrage.
C'est pour cette raison aussi qu'il n'y a pas de cellule rouge.

Attendons @eriiiic et sa solution. Je m'y remettrai peut-être après :rolleyes:

nota : Ce que je trouve c'est une solution pas trop nulle. Ce n'est sans doute pas la meilleure solution. C'est souvent le cas dans ce type de problème.
 
Dernière édition:

Raka

XLDnaute Occasionnel
En tout état de cause, ce n'était pas une critique, juste une constatation.

Si jamais, je me "contente" de ça avec un immense plaisir et beaucoup de remerciements.
C'est vingt fois plus complet que ce que je suis capable de faire moi-même.
Mon exemple illustre bien les limites de ce que je sais coder :)

Je m'y suis mis il y a quelques jours sur de très vieux souvenirs de basic, entre autres (j'ai appris à programmer sur Amstrad il y a... presque 30 ans.) Alors ça avance et ce genre d'exemple me le permet.
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Re @Raka ;),

En fait en relisant mon code, je me suis aperçu que j'avais mis une ligne désormais inutile et qui ralentit fortement le code. Il faut supprimer "Doevents"
remplacer :
VB:
   For i = 1 To UBound(d)
      DoEvents
      If d(i).Count > 0 Then
par
Code:
   For i = 1 To UBound(d)
      If d(i).Count > 0 Then

nota: cette instruction (DoEvents) permet de pouvoir utiliser la touche ESCape pour stopper la macro même quand on est dans une boucle sans fin (ce qui peut être le cas pendant la phase de mise au point et l'utilisation de boucle Do ...Loop avec des conditions de sorties jamais vraies)
 

Pièces jointes

  • Raka- Exemple- v2a.xlsm
    83.6 KB · Affichages: 22

Raka

XLDnaute Occasionnel
Ah oui en effet, je viens de remplacer et ça rame plus du tout.
C'est de la sorcellerie.

En vérité, je comprends la logique du code. Après une ou deux recherches sur les fonctions qui m'étaient inconnues ou peu familières.
Tout, dans le code, me semble "évident".
Mais du coup, l'écrire moi-même, même si je devais simplement le réécrire sur du blanc, ... fiou, je m'y vois pas trop.
 
Dernière édition:

eriiic

XLDnaute Barbatruc
J'ai dû m'absenter.
En temps normal je n'aurais pas repris vu que la proposition de mapomme est suffisamment rapide, mais comme je n'avais plus qu'une ligne à écrire avant débogage autant finir :)
Je suis un poil plus rapide : 0.29 s contre 0.54 s sur mon PC.
Peut-être que tu arriveras mieux à comprendre ce code.
Le principe est simple : la colonne en cours de chaque ligne est dans un tableau cpt(lig).
=0 si ligne non (ou plus) utilisable pour les passer plus vite.
eric
 

Pièces jointes

  • RakaExemple.xlsm
    375.6 KB · Affichages: 4

Raka

XLDnaute Occasionnel
Je vais la regarder, mais plus ce soir, j'ai eu ma dose :D Merci !

Par contre, j'en profite (plutôt que de créer un sujet juste pour ça), pour la suite, je vais lire quelles sont les cellules colorées, une à une (est-ce que G3 est coloré, est-ce que H3 est coloré, etc), mais du coup je vais plus facilement le faire via formule (je m'en sors mieux et ce que je veux faire n'est pas susceptible de nécessiter du vba)

Du coup, j'ai créé une fonction personnalisée pour m'en servir sous la forme "=SI ([fonction perso](Cell, (200, 225, 180)); vrai ; faux)

Mais alors je bute un poil sur la macro de la fonction perso.
Je pense tout avoir, mais comment lui faire comprendre qu'elle doit renvoyer une valeur vraie pour le SI utilisé en formule ?
Voici ce que j'ai :


VB:
Function IsColor(Plage As Range, Color As String) As Double
Application.Volatile True
Dim wCell As Range
For Each wCell In Plage
    If wCell.Interior.Color = Color.Value Then
    ' renvoyer "vrai" pour le =SI (IsColor(G2;(200, 225, 180)) ;

End If
Next
End Function

Est-ce la bonne méthode ?
Une fois ceci fait, mon document sera enfin terminé, pffff.... Il était temps.
 

eriiic

XLDnaute Barbatruc
J'avais oublié une optimisation. 0.25 s maintenant.

Dans ma macro tu peux te servir de plCoul si tu veux la plage des cellules utilisées.
Soit directement, soit en la préservant dans une variable globale pour l'utiliser ensuite . Tu fais un intersect dessus.
eric

et ce que je veux faire n'est pas susceptible de nécessiter du vba
heuuu, une fonction personnalisée c'est quoi ? ;)
 

Pièces jointes

  • RakaExemple.xlsm
    374.9 KB · Affichages: 5

Raka

XLDnaute Occasionnel
Hm... intéressant.
Mais du coup, les valeurs du tableau sont dynamiques en fonction de plusieurs variables (toutes en formule dans les cases). Et il y a une variable en particulier parmi elles dont j'aurai besoin par la suite.

C'est pour que ça que voulais une fonction perso =SI(Cellule;RGB(...)) ; et c'est là que je devrai mettre un autre SI qui se sert de cette variable pour définir un calcul ou un autre. Quitte à rentrer le RGB directement dans la fonction perso pour en faire un =SI(Celluleverte ;

Il faut juste que j'arrive à créer cette fonction perso :D Je ne suis plus très loin d'y arriver, je pense.
 

eriiic

XLDnaute Barbatruc
Dans ce cas :
VB:
Function IsColor(c As Range, Color As Long) As Boolean
    Application.Volatile True
    IsColor = c(1).Interior.Color = Color
End Function
c'est la 1ère cellule de la plage qui est prise en compte s'il y en a plusieurs.
=IsColor(H5;65280) => VRAI sur mon fichier
eric

PS : n'oublie pas que tu dois faire F9 pour forcer un recalcul et mettre à jour la fonction.
A toi de voir si tu l'intégres en fin de macro : Sheets("Autocalc").Calculate
 

Statistiques des forums

Discussions
313 271
Messages
2 096 725
Membres
106 720
dernier inscrit
Alain EDZOA