Surlignage avec condition en vba

Hello à vous

Dans une feuille Excel je répertorie :
Quelques pronostics pour certaines courses de chevaux (chaque Pronostiqueur a son pronostic dans 1 cellule)
et le Résultat de la course sont dans des cellules séparées
(je mets chaque pronostic dans 1 cellule pour chacun pour gain de place.)

voir cette image :
https://i.imgur.com/AATP8Vx.png

je souhaiterais, via un bouton,
=> si les 5 cases de "Arrivée" se retrouve dans un des pronostics, celui ci soit surligné en jaune (ou autre couleur peu importe ..)
cela me permettrait de voir tout de suite si un pronostiqueur a fait le bon pronostic

Je saurais le faire si les pronostics étaient dans des cellules séparées mais vu que chaque pronostic est dans une cellule unique, je ne vois pas comment faire...

merci de votre aide par avance

Bonjour,

Une façon de faire avec une fonction personnalisée utilisée dans une mise en forme conditionnelle.

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Option Explicit   Public Function PTop(cP As Range) As Boolean '--- cP: cellule contenant le pronostic Dim kR As Long, kC As Long, v As String kR = cP.Row v = cP.Value & " " '--- ajout un espace en fin PTop = True For kC = 6 To 10 '--- n° colonnes arrivées If InStr(v, Cells(kR, kC) & " ") = 0 Then PTop = False Exit For End If Next kC End Function

---

Cordialement.

Re EricDgn,

Merci de t'être intéressé au pb .

Possible de me mettre le fichier au format excel 2003 (xls) ?

.. je ne peux pas ouvrir le format .xlsm (suis sous ecsl 2003)

En attaché la version .xls
Cordialement.

Salut

Pourquoi ne pas utiliser un MFC (Mise En forme Conditionnelle)?
Plutôt que de chercher à séparer les valeur contenu dans les 3 premières cellules, pourquoi ne pas concaténer les résultats et le comparer au 3 1ères cellules?

C'est sans doute améliorable mais dans l'esprit, ça donnerait un truc comme ça

Code:

---

=SIERREUR(CHERCHE(CONCATENER(G12;" ";H12;" ";I12;" ";J12;" ";K12);D12);FAUX)

---

A placer dans la MFC

++
Qwaz

Oui c'est tout à fait bon s'il faut considérer le pronostic ok uniquement s'il respecte vraiment l'ordre d'arrivée. Pour ma part j'ai considéré qu'il suffisait que les arrivées soient dans le pronostic, dans l'ordre ou le désordre. On pourrait d'ailleurs surement aussi mettre cela dans une seule formule par 5 CHERCHE() additionnés.

Bien cordialement.

Oui aussi en effet.

Sinon coté organisation des données, si le seul handicape est la place occupé par le tableau, tu pourrais mettre 5 ou 6 colonnes petites colonnes par pronostique et fusionner les cellule contenu sur les lignes d'entêtes "pronostiqueurs".
Le tableau ne prendrait pas plus de place et au moins si d'autre contrôles sont à effectuer, ça ne sera pas... ou du moins, ça sera sans doute moins casse tête.

++
Qwaz

bonjour,
j'ai mis le temps à répondre :aie: car j'ai du adapter un de mes codes :D

d'abord, voila le contexte :
Pièce jointe 614551

j'ai ajouté une la colonne "J" qui concatène avec formule la colonne "I" ... cette colonne n'est pas obligatoire , c'est pour la démo :D

voila le form :
Pièce jointe 614552

normalement on peut sélectionner la ou les cellules de résultat en cliquant sur la feuille , ICI les cellules sont indiquées en dur dans le code ...

comme tu peu le voir,
la ligne 1 des textbox représente les valeurs à rechercher
la ligne 2 des textbox représente les valeurs sélectionnées pour la recherche :weird:

toutes les valeurs sont sélectionnées par default , mais tu peu rechercher des chevaux séparément :
Pièce jointe 614554

la recherche fonctionne sur une comparaison des valeurs des "octets binaires"
dans la dernière image on voit le masque "10100" et sa valeur "160"

LE CODE

l'appel du bouton pour lancer le form :

Code:

---

1 2 3 4

Private Sub CmdAppelForm2_Click() USF2.Show 0 End Sub

---

le form:

Code:

---

1 2 3 4 5 6 7 8 9 10 11

'======================================================= form Private Sub UserForm_Initialize() Test_USF2_IsLoad = True For n = 6 To 10 USF2.Controls("TextBox" & n).Value = "0" Next n End Sub Private Sub UserForm_Terminate() Test_USF2_IsLoad = False End Sub

---

la ligne 1 des TextBox ... 1 à 5 (valeur de recherche)
la ligne 2 des TextBox ... 6 à 10 (masque)

la capture de la cellule (ou des cellules ... valeur de recherche)

Code:

---

1 2 3 4 5 6 7 8 9 10 11

'======================================================= capturer une cellule Private Sub BtnCapture_Click() If USF2.BtnCapture.Value = True Then Test_USF2_IsCaptureON = True Call CaptureCellule2(ActiveCell.Value) Else Test_USF2_IsCaptureON = False End If End Sub

---

la sub CaptureCellule2 et les déclarations

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34

Public Test_USF2_IsLoad As Boolean Public Test_USF2_IsCaptureON As Boolean Public Test_USF2_IsMasqueMakingON As Boolean Public Sub CaptureCellule2(Data As String) 'efface les TextBox For n = 1 To 5 USF2.Controls("TextBox" & n).Value = "" Next n 'remplissage des TextBox If USF2.OptionPlageCellule = True Then 'plage de cellule For n = 1 To 5 USF2.Controls("TextBox" & n).Value = Sheets("test2").cells(2, 4 + n).Value Next n Else 'mise en tableau de la cellule J2 TabTmp = Split(Sheets("test2").Range("J2").Value, " ") 'remplissage des TextBox par les valeurs du tableau For n = 0 To 4 USF2.Controls("TextBox" & n + 1).Value = TabTmp(n) Next n End If If USF2.OptionFullSelect = True Then For n = 1 To 5 USF2.Controls("TextBox" & (n + 5)).SpecialEffect = 2 USF2.Controls("TextBox" & (n + 5)).BackColor = &H808080 USF2.Controls("TextBox" & (n + 5)).ForeColor = &HE0E0E0 USF2.Controls("TextBox" & (n + 5)).Value = 1 USF2.Controls("TextBox" & n).BackColor = &H808080 USF2.Controls("TextBox" & n).ForeColor = &HE0E0E0 Next n End If End Sub

---

le bouton modif du masque (pour sélectionner des valeurs séparément) :

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37

'======================================================= masque modif Private Sub BtnMasque_Click() If USF2.BtnMasque.Value = True Then Test_USF2_IsMasqueMakingON = True Else Test_USF2_IsMasqueMakingON = False End If End Sub   Private Sub LblGlass_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Test_USF2_IsMasqueMakingON Then If USF2.Controls("TextBox" & (Int(X / 16) + 1)).Value <> "" Then '16= largeur TextBox (14) + espace (2) If USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).SpecialEffect = 1 Then USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).SpecialEffect = 2 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).BackColor = &H808080 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).ForeColor = &HE0E0E0 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).Value = 1 USF2.Controls("TextBox" & (Int(X / 16) + 1)).BackColor = &H808080 USF2.Controls("TextBox" & (Int(X / 16) + 1)).ForeColor = &HE0E0E0 Else USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).SpecialEffect = 1 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).BackColor = &HE0E0E0 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).ForeColor = &H80000008 USF2.Controls("TextBox" & (Int(X / 16) + 1) + 5).Value = 0 USF2.Controls("TextBox" & (Int(X / 16) + 1)).BackColor = &HE0E0E0 USF2.Controls("TextBox" & (Int(X / 16) + 1)).ForeColor = &H80000008 End If MasqueTxt = "" For n = 6 To 10 MasqueTxt = MasqueTxt & USF2.Controls("TextBox" & n).Value Next n USF2.BtnChercher.Caption = "Chercher : " & BinToTxt(MasqueTxt) End If End If End Sub

---

le code est peut être "bizarre" :calim2: mais en fait j'utilise un label transparent (glass) quand j'ai beaucoup de contrôle à cibler (ici 5 , c'est peu mais mon ancien code utilisait 2 octet , soit 16 bit :mouarf: voir plus ...)

la sub de recherche:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

'======================================================= Chercher Private Sub BtnChercher_Click() USF2.ListBox1.Clear USF2.ListBox2.Clear '----- masque MasqueTxt = "" For n = 6 To 10 MasqueTxt = MasqueTxt & USF2.Controls("TextBox" & n).Value Next n MasqueValeur = BinToTxt(MasqueTxt) '----- Data1 Dim TabData1(6) '6 parceque tableau commence avec "0" 0,1,2,3,4,5 Erase TabData1 'valeur à chercher For n = 1 To 5 TabData1(n) = USF2.Controls("TextBox" & n).Value Next n '----- colonne A à D For Colon = 1 To 4 'nombre de ligne de la colonne : colon LigneFin = Cells(Rows.Count, Colon).End(xlUp).Row 'boucle sur la colonne For n = 2 To LigneFin '2 pour sauter ligne 1 (titre) 'valeur de la cellule dans DataLigne DataLigne = Cells(n, Colon).Value 'mise en tableau de DataLigne TabData2 = Split(DataLigne, " ") 'valeur de la cellule 'efface variable de comparaison Data3 = "" 'résultat de comparaison en valeur OctetBinaire 'nombre de bit Lng = 5 '----- For n2 = 1 To Lng If TabData1(n2) = TabData2(n2) Then Data3 = Data3 & "0" 'case valeur à chercher = case valeur cellule Else Data3 = Data3 & "1" End If Next n2 '----- 'BinToTxt(Data3) transforme la comparaison (Data3) en valeur OctetBinaire 'MasqueValeur est la valeur OctetBinaire de la valeur de recherche If BinToTxt(Data3) = MasqueValeur Then USF2.ListBox2.AddItem "Pronostiqueur " & Colon & "|" & "Ligne " & n & "|" & DataLigne ElseIf Data1 = Data2 Then USF2.ListBox1.AddItem "Pronostiqueur " & Colon & "|" & "Ligne " & n & "|" & DataLigne End If Next n Next Colon USF2.BtnChercher.Value = False End Sub

---

et la fonction de codage (valeur binaire)

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66

'======================================================= fonction Function BinToTxt(ByVal Data As String) As String If Len(Data) = 16 Then For n = 1 To 16 Select Case n Case 1 If Mid(Data, n, 1) = 1 Then tmp = tmp + 32768 Case 2 If Mid(Data, n, 1) = 1 Then tmp = tmp + 16384 Case 3 If Mid(Data, n, 1) = 1 Then tmp = tmp + 8192 Case 4 If Mid(Data, n, 1) = 1 Then tmp = tmp + 4096 Case 5 If Mid(Data, n, 1) = 1 Then tmp = tmp + 2048 Case 6 If Mid(Data, n, 1) = 1 Then tmp = tmp + 1024 Case 7 If Mid(Data, n, 1) = 1 Then tmp = tmp + 512 Case 8 If Mid(Data, n, 1) = 1 Then tmp = tmp + 256 Case 9 If Mid(Data, n, 1) = 1 Then tmp = tmp + 128 Case 10 If Mid(Data, n, 1) = 1 Then tmp = tmp + 64 Case 11 If Mid(Data, n, 1) = 1 Then tmp = tmp + 32 Case 12 If Mid(Data, n, 1) = 1 Then tmp = tmp + 16 Case 13 If Mid(Data, n, 1) = 1 Then tmp = tmp + 8 Case 14 If Mid(Data, n, 1) = 1 Then tmp = tmp + 4 Case 15 If Mid(Data, n, 1) = 1 Then tmp = tmp + 2 Case 16 If Mid(Data, n, 1) = 1 Then tmp = tmp + 1 End Select Next n   Else For n = 1 To 8 Select Case n Case 1 If Mid(Data, n, 1) = 1 Then tmp = tmp + 128 Case 2 If Mid(Data, n, 1) = 1 Then tmp = tmp + 64 Case 3 If Mid(Data, n, 1) = 1 Then tmp = tmp + 32 Case 4 If Mid(Data, n, 1) = 1 Then tmp = tmp + 16 Case 5 If Mid(Data, n, 1) = 1 Then tmp = tmp + 8 Case 6 If Mid(Data, n, 1) = 1 Then tmp = tmp + 4 Case 7 If Mid(Data, n, 1) = 1 Then tmp = tmp + 2 Case 8 If Mid(Data, n, 1) = 1 Then tmp = tmp + 1 End Select Next n End If BinToTxt = tmp End Function

---

:coucou: @+JP


PS : j'ai corrigé 2 erreurs ( cells pour cell et aussi des groupname pour les options) et j'ai donc posté un nouveau fichier v9

Salut

J'ai juste regardé le code en diagonal mais il me semble que les répétitions dans la procédure BinToStr peuvent être remplacées par quelque chose comme ça

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Function BinToTxt(ByVal Data As String) As String Dim tmp As Long Dim n As Byte Dim BorneUp As Byte   If Len(Data) <= 16 Then BorneUp = IIf(Len(Data) <= 8, 8, 16)   For n = 1 To BorneUp If Mid(Data, n, 1) = 1 Then tmp = tmp + 2 ^ (BorneUp - n) Next n End If   BinToTxt = tmp End Function

---

Je dirais aussi, qu'en inversant le poids des bits, je pense qu'il ne serait plus nécessaire de chercher si le mot est codé en 8 ou 16 bits.

++
Qwaz

bonjour,

oui tout à fait :D , mais avec mon code simplifié , on comprend bien le mécanisme !!!

c'est sur qu' on peut "resserrer" le code ,

j'en profite pour préciser que pour surligner on a les coordonnées quand on écrit les résultats de recherche

Citation:

---

Je dirais aussi, qu'en inversant le poids des bits, je pense qu'il ne serait plus nécessaire de chercher si le mot est codé en 8 ou 16 bits.

---

oui surtout que ICI on à un nombre précis de 5 bits :mouarf:


@+JP

Attention aussi, si le data est codé de 9 à 15 bits, c'est le calcul du 8 bit qui sera utilisé, avec perte de donnée et résultat erroné.

++
Qwaz

bonjour,
en fait il y a une arrivée de 5 chevaux , ce qui donne 5 cases/TextBox et donc 5 bits ( un bit par case)
le mécanisme reste sur 5 , autant en valeur qu'en recherche

@+JP

Bonjour,

Citation:

---

Envoyé par EricDgn

Bonjour,

Une façon de faire avec une fonction personnalisée utilisée dans une mise en forme conditionnelle.

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Option Explicit   Public Function PTop(cP As Range) As Boolean '--- cP: cellule contenant le pronostic Dim kR As Long, kC As Long, v As String kR = cP.Row v = cP.Value & " " '--- ajout un espace en fin PTop = True For kC = 6 To 10 '--- n° colonnes arrivées If InStr(v, Cells(kR, kC) & " ") = 0 Then PTop = False Exit For End If Next kC End Function

---

Cordialement.

---

Attention, si on gère avec des tests de chaînes de caractères, il faut également ajouter un espace avant.
Sinon un pronostic à 15 avec une arrivée à 5 sera considéré bon.

Note : j'ajouterais également la plage des arrivées à la fonction plutôt que d'avoir en dur les colonnes 6 à 10.

Bonjour,

Effectivement, bien vu! Aussi, une version corrigée, avec plage des arrivées.

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Option Explicit   Public Function PTop(cP As Range, rA As Range) As Boolean '--- cP: cellule contenant le pronostic, rA: plage contenant les arrivées Dim kR As Long, kC As Long, v As String kR = cP.Row v = " " & cP.Value & " " '--- ajout espace en fin et en début PTop = True For kC = 1 To 5 '--- n° colonnes arrivées If InStr(v, " " & rA(kC) & " ") = 0 Then '--- idem espace avant et après PTop = False Exit For End If Next kC End Function

---

Cordialement.