Discussion :

[nivk-539]

Bonjour,

J'ai un code qui me permet de colorier des cellules en fonction d'une saisie dans un inputbox. J'ai dans ma colonne A de ma feuille une liste de noms (nom-1 dans cellule A1 jusqu'à nom-n dans la cellule An). Si je mets dans mon input box par exemple 1/5,7/12 les cellules de nom-1 jusqu'à nom-5, ainsi que de nom-7 à nom-12 se colorient en orange, et nom-6 en bleu. Ce que j'aimerai faire maintenant, c'est de réussir à colorier les cellules même si je mets toto en texte à la place de nom-1 etc... J'ai essayé de faire cela avec le MFC mais ça ne marche pas. Merci pour votre aide!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
    Dim x$, c1 As Range, c2 As Range, nums As Variant, serie As Variant
    x = InputBox("entrez un/deux numeros")
    If x <> vbNullString Then     ' si on annule pas et que la chaine tapée correspond a un chiffre + "/" + un chiffre
        With Sheets(1).Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            'on met tout en bleu au depart
            .Parent.Range(.Cells(1, 1), .Cells(.Cells.Count)).Interior.Color = RGB(0, 150, 255)
            serie = Split(x, ",")
            For s = 0 To UBound(serie)
                If Not serie(s) Like "*/*" Then serie(s) = serie(s) & "/" & serie(s)
                If IsNumeric(Replace(serie(s), "/", "")) And serie(s) Like "*#/#*" Then
                    nums = Split(serie(s), "/")
                    'on cherche le 1°chiffre nom-+ nums(0)
                    Set c1 = .Find("nom-" & nums(0), lookat:=xlWhole)
                    'on cherche le 2d chiffre nom-+ nums(1)
                    Set c2 = .Find("nom-" & nums(1), lookat:=xlWhole)
                    critere = Not c1 Is Nothing And Not c2 Is Nothing
                    'si c1 n'est pas rien
                    If critere Then .Parent.Range(c1, c2).Interior.Color = RGB(255, 200, 50) Else mess = mess & "la plage contenant  ""nom-" & nums(0) & """ & ""nom-" & nums(1) & """ n'existe pas !!" & vbCrLf
                Else
                    mess = " la serie " & serie(s) & " n'est pas valide" & vbCrLf
                End If
                Next
                If mess <> "" Then MsgBox mess
            End With
        Else
            MsgBox "vous avez annulé"
        End If
    End Sub

[ARTURO83]

Bonsoir,

Voici une proposition, je n'ai traité que le cas NOM/NOM reste à faire NOM/NUM ou NUM/NOM.

En vous inspirant de ce qui est fait, vous devriez pouvoir faire le reste sans problème

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
    Dim x$, c1 As Range, c2 As Range, nums As Variant, serie As Variant
    x = InputBox("entrez un/deux numeros")
    If x <> vbNullString Then     ' si on annule pas et que la chaine tapée correspond a un chiffre + "/" + un chiffre
        With Sheets(1).Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            'on met tout en bleu au depart
            .Parent.Range(.Cells(1, 1), .Cells(.Cells.Count)).Interior.Color = RGB(0, 150, 255)
            serie = Split(x, ",")
            For s = 0 To UBound(serie)
                If Not serie(s) Like "*/*" Then serie(s) = serie(s) & "/" & serie(s)
                If IsNumeric(Replace(serie(s), "/", "")) And serie(s) Like "*#/#*" Then
                    nums = Split(serie(s), "/")
                    'on cherche le 1°chiffre nom-+ nums(0)
                    Set c1 = .Find("nom-" & nums(0), lookat:=xlWhole)
                    'on cherche le 2d chiffre nom-+ nums(1)
                    Set c2 = .Find("nom-" & nums(1), lookat:=xlWhole)
                    critere = Not c1 Is Nothing And Not c2 Is Nothing
                    'si c1 n'est pas rien
                    If critere Then .Parent.Range(c1, c2).Interior.Color = RGB(255, 200, 50) Else mess = mess & "la plage contenant  ""nom-" & nums(0) & """ & ""nom-" & nums(1) & """ n'existe pas !!" & vbCrLf
                ElseIf Not IsNumeric(Replace(serie(s), "/", "")) And serie(s) Like "*/*" Then
                    'on cherche le 1er nom
                    Nom = Split(x, "/")
                    For j = 0 To UBound(Nom)
                        If j = 0 Then y = Nom(j)
                        If j = 1 Then Z = Nom(j)
                    Next
                    Set c1 = .Find(y & "*~", lookat:=xlWhole)
                    'on cherche le 2d chiffre nom-+ nums(1)
                    Set c2 = .Find(Z & "*~", lookat:=xlWhole)
                    critere = Not c1 Is Nothing And Not c2 Is Nothing
                    'si c1 n'est pas rien
                    If critere Then .Parent.Range(c1, c2).Interior.Color = RGB(255, 200, 50) Else mess = mess & "la plage contenant  x &  ""nom-" & nums(1) & """ n'existe pas !!" & vbCrLf
                 End If
            Next
            If mess <> "" Then MsgBox mess
        End With
    Else
        MsgBox "vous avez annulé"
    End If
End Sub

Avec le fichier
Pièce jointe 430389

Cdlt

[John Mc Evee]

Bonjour,

Le problème venait de ta recherche qui était stricte (xlWhole) et de ton critère IsNumeric. Je te propose un exemple de code qui intègre à la fois une recherche stricte et partielle. Elle permet de chercher des index comme des chaînes de texte. Le caractère strict ou non de la recherche est éffectuer par l'énumération XlLookAt de la fonction FromTo.

En espérant avoir répondu à tes besoins. Je ne l'ai pas testé à 100% il peut y avoir des bugs.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Option Explicit
'*******************************************************************************************************
' NAME : ColorInput (PROCESS)
'*******************************************************************************************************
Public Sub ColorInput()
 
    Dim sCharSerie As String        ' Caractère qui sert à délimiter les séries
    Dim vSerie     As Variant       ' Tableau contenant les différentes séries
    Dim vCritere   As Variant       ' Valeur contenant les critères
    Dim iBuffer    As Integer       ' Compteur
    Dim lColor1    As Long          ' Couleur de surbrillance initiale
    Dim lColor2    As Long          ' Couleur de surbrillance si le critre est correcte
    Dim oRange     As Excel.Range   ' Plage contenant les données
    Dim oSelection As Excel.Range   ' Plage spécifique à un critère
 
    ' Paramétrage
    sCharSerie = ","
    lColor1 = VBA.RGB(0, 150, 255)  ' Choisir la couleur de départ (bleu)
    lColor2 = VBA.RGB(255, 200, 50) ' Choisir la couleur de surbrillance (Orange)
    Set oRange = Sheets(1).Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
 
    ' Saisi des criteres de surbrillance
    ' Le caractère "/" définit une plage continue (de ... à ...)
    ' Le caractère "," définit une autre plage ( ... et de ... à ...)
    vCritere = VBA.InputBox("entrez un/deux numéros")
 
    If vCritere = VBA.vbNullString Then 'Si l'on a rien saisie
        VBA.MsgBox "Vous avez annulé"
        Exit Sub
    End If
 
    'Couleur initiale
    oRange.Interior.Color = lColor1
 
    ' On split les critères en fonction de sCharSerie
    vSerie = VBA.Split(vCritere, sCharSerie)
 
    ' Boucle sur les différentes séries
    For iBuffer = LBound(vSerie) To UBound(vSerie)
 
        vCritere = vSerie(iBuffer) ' Affection du critère
 
        ' Sélection de la plage
        ' La fonction FromTo intègre deux options (voir la description)
        Set oSelection = FromTo(oRange, vCritere)
 
        If Not oSelection Is Nothing Then
            oSelection.Interior.Color = lColor2 ' Mise en surbrillance
        End If
 
    Next iBuffer
 
    Set oRange = Nothing 'Vidange
 
End Sub
 
'*******************************************************************************************************
' NAME : FromTo (FUNCTION)
' INPUT : oRange, vCritere, sCharCritere, eXlLookAt
' OUTPUT : Range
' DESCRIPTION : La fonction permet de sélectionner une plage en fonction de deux critères séparer par
' par un caractère (par défaut /).
' L'émumération XlLookAt permet d'éffectuer une recherche stricte (xlWhole) ou partielle (xlPart) comme
' par exemple avec "nom-" & numéro
'*******************************************************************************************************
Public Function FromTo(oRange As Excel.Range, vCritere As Variant, _
                       Optional sCharCritere As String = "/", _
                       Optional eXlLookAt As XlLookAt = xlWhole) As Excel.Range
 
 
    Dim oFirstRange As Excel.Range  ' Cellule du premier critère
    Dim oLastRange  As Excel.Range  ' Cellule du second critère
    Dim vCritere1   As Variant      ' Valeur du critère 1
    Dim vCritere2   As Variant      ' Valeur du critère 2 si CharCritère <> ""
 
    On Error Resume Next
    vCritere1 = VBA.Split(vCritere, sCharCritere)(0)
    vCritere2 = VBA.Split(vCritere, sCharCritere)(1)
 
    'Si il n'y a pas de critère alors rien sinon on recherche
    If vCritere1 = VBA.vbNullString Then
        FromTo = Nothing
        Exit Function
    Else
        Set oFirstRange = oRange.Find(vCritere1, , xlValues, eXlLookAt)
    End If
 
    'Si il n'y a pas de critère alors on affecte la première cellule sinon on recherche
    If vCritere2 = VBA.vbEmpty Then
        Set oLastRange = oFirstRange
    Else
        Set oLastRange = oRange.Find(vCritere2, , xlValues, eXlLookAt)
    End If
 
    'Test de complétude
    If Not oFirstRange Is Nothing And Not oLastRange Is Nothing Then
        Set FromTo = Range(oFirstRange.Address, oLastRange.Address)
    Else
        Set FromTo = Nothing
    End If
 
End Function

Avec le fichier ci-joint.
Pièce jointe 430413

A+

[nivk-539]

Merci à vous 2 pour vos réponses.
J'ai essayé le code rapidement et je ne suis pas sûr que cela corresponde à ce que je veux. Peut-être que je me suis mal exprimé...
En fait si vous voulez, mon code initial me permet de colorier des cellules en fonction d'une saisie dans un inputbox. J'ai dans ma colonne A de ma feuille une liste de noms (nom-1 dans cellule A1 jusqu'à nom-n dans la cellule An). Si je mets dans mon input box par exemple 1/5,7/12 les cellules de nom-1 jusqu'à nom-5, ainsi que de nom-7 à nom-12 se colorient en orange, et nom-6 en bleu. Ce que j'aimerai faire maintenant, c'est de réussir à colorier les cellules même si je remplace tous mes nom-1, nom-2 jusqu'à nom-n par des textes différents dans toutes mes cellules (par exemple toto à la place de nom-1, bonjour à la place de nom-2 etc...). ARTURO83 je pense que ta solution se rapproche plus de ce que je veux là je n'ai pas vraiment le temps de regarder le code mais je te retiendrai au courant si je réussis

[John Mc Evee]

Salut,

ok à toi de voir le plus important est d'arriver à tes fins.

J'avais bien compris ce que tu voulais faire.

J'ai rectifier la plage de donnée car la fonction Find ne prend pas en compte la donnée situé sur la première ligne et quand je recherchais 1 il interprétait 10

J'ai effectué les tests expliqués 1/5,7/12 et avec des noms comme toto ou durand.

Juste une petite question complémentaire : Tu explique dans ton exemple (1/5,7/12) que le 6 doit être en bleu mais le 13 et les nombres après aussi ?

Voir le fichier ci-joint
Pièce jointe 430488

A+

[nivk-539]

merci pour ta répinse
En fait les plages qui sont définis avec un slash se colorient en orange et finalement on peut considérer que la virgule permet de faire aussi des plages en bleu donc je peux avoir une infinité de cellules, c'est juste que je définis mes plages en orange avec mes slash puisque le bleu est la couleur de départ. Du coup j'ai testé ton code mais si je change tous mes noms de cellules ça ne marche pas :/
Ce qu'il faut c'est de ne plus avoir une seule cellule avec comme texte nom-n car je veux que toutes mes cellules ont des noms différents. Je peux très bien mettre a,b,c,d ... jusqu'à la dernière cellule en fait