Autres VBA Chaîne de caractères de couleur à extraire dans cellule Excel

[Armand11]

Bonjour à toute la communauté ExcelDownLoad !J'espère que vous allez bien ?
Je sollicite humblement vos compétences ma fonction VBA ne fonctionne pas pour :

a. Extraire d'une cellule la chaine de caractères alphabétiques en Bleus
b. J'ai bien fait attention à appliquer les bons codes RGB pour le bleu à savoir (0 , 0, 255)

je vous joins mon fichier de travail et reste attentif à vos retours si vous pouvez m'aider et m'expliquer où ma fonction pêche ...
Mille mercis
Armand

 

[sylvanu]

Bonjour Armand,

J'ai bien fait attention à appliquer les bons codes RGB pour le bleu à savoir (0 , 0, 255)

Heureusement. 😅 car votre bleu, je le trouve à RGB(0,0,153) et non RGB(0,0,255)
pour éviter tout problème, je remonte tout caractère non noir. Mais c'est facile à adapter.
Un essai en PJ avec cette fonction :

Function Bleu(C)
For i = 1 To Len(Cells(C, "A"))
    If Cells(C, "A").Characters(Start:=i, Length:=1).Font.Color <> 0 Then
        Bleu = Bleu & Mid(Cells(C, "A"), i, 1)
    End If
Next i
End Function

 

[mapomme]

Bonjour @Armand11 🙂,

Pas de macro dans votre classeur joint 🙁.

 

[mapomme]

Re,

Et le bleu de la police de votre classeur est le RGB(0,0,153) et pas le RGB(0,0,255).

 

[Eric KERGRESSE]

Bonjour,

Je n'ai pas chargé la macro complémentaire pour cette fonction.

Sinon, si votre fichier admet les macros (.xlsm) :

Function RecupChaine(ByVal LaCellule As Range) As String

Dim I As Integer

    RecupChaine = ""
    With LaCellule
         For I = 1 To .Characters.Count
            If .Characters(I, 1).Font.ColorIndex > 1 Then RecupChaine = RecupChaine & Mid(LaCellule.Value, I, 1)
         Next I
    End With
    If Len(RecupChaine) > 0 Then
       Select Case Mid(RecupChaine, 1, 1)
              Case Chr(32), Chr(160)
                   RecupChaine = Mid(RecupChaine, 2)
       End Select
   End If

End Function

 

[Armand11]

Bonjour,

Je n'ai pas chargé la macro complémentaire pour cette fonction.

Sinon, si votre fichier admet les macros (.xlsm) :

Function RecupChaine(ByVal LaCellule As Range) As String

Dim I As Integer

    RecupChaine = ""
    With LaCellule
         For I = 1 To .Characters.Count
            If .Characters(I, 1).Font.ColorIndex > 1 Then RecupChaine = RecupChaine & Mid(LaCellule.Value, I, 1)
         Next I
    End With
    If Len(RecupChaine) > 0 Then
       Select Case Mid(RecupChaine, 1, 1)
              Case Chr(32), Chr(160)
                   RecupChaine = Mid(RecupChaine, 2)
       End Select
   End If

End Function

Bonsoir Eric,

Merci pour le Code, mais j'ai essayé de le pratiquer dans mon fichier mais il m'affiche #NOM?
De plus il me demande de nommer le module lorsque je finis de l'insérer ...
Merci pour votre aide Eric. En pièce jointe mon fichier avec votre code

 

[Armand11]

Bonjour Armand,

Heureusement. 😅 car votre bleu, je le trouve à RGB(0,0,153) et non RGB(0,0,255)
pour éviter tout problème, je remonte tout caractère non noir. Mais c'est facile à adapter.
Un essai en PJ avec cette fonction :

Function Bleu(C)
For i = 1 To Len(Cells(C, "A"))
    If Cells(C, "A").Characters(Start:=i, Length:=1).Font.Color <> 0 Then
        Bleu = Bleu & Mid(Cells(C, "A"), i, 1)
    End If
Next i
End Function

Re,

Et le bleu de la police de votre classeur est le RGB(0,0,153) et pas le RGB(0,0,255).

Bonsoir Sylvanu, Merci pour le retour mais j'ai des #NOM? comme résultat...
Je comprends pas ...
En pièce jointe le fichier
Merci encore

 

[patricktoulon]

Bonjour
a oui c'est rigolo ça
je peux jouer moi aussi
en voila une qui detecte plusieurs sorte de bleu

Function extractChainebleuVague(cel As Range)
   Dim i&, str0, r&, g&, b, chaine
   For i = 1 To Len(cel)
        str0 = Right("000000" & Hex(cel.Characters(Start:=i, Length:=1).Font.Color), 6)
         r = CDbl("&H" & Right(str0, 2))
        g = CDbl("&H" & Mid(str0, 3, 2))
        b = CDbl("&H" & Left(str0, 2))
        Debug.Print r & " , " & g & " , " & b
        If b > r And b > g Then chaine = chaine & Mid(cel, i, 1) Else chaine = chaine & " "
    Next i
    extractChainebleuVague = Application.Trim(chaine)
End Function

Sub test()
MsgBox extractChainebleuVague([A1])
End Sub

en formule c'est
=extractChainebleuVague(A1)

 

[Armand11]

Bonjour
a oui c'est rigolo ça
je peux jouer moi aussi
en voila une qui detecte plusieurs sorte de bleu

Function extractChainebleuVague(cel As Range)
   Dim i&, str0, r&, g&, b, chaine
   For i = 1 To Len(cel)
        str0 = Right("000000" & Hex(cel.Characters(Start:=i, Length:=1).Font.Color), 6)
         r = CDbl("&H" & Right(str0, 2))
        g = CDbl("&H" & Mid(str0, 3, 2))
        b = CDbl("&H" & Left(str0, 2))
        Debug.Print r & " , " & g & " , " & b
        If b > r And b > g Then chaine = chaine & Mid(cel, i, 1) Else chaine = chaine & " "
    Next i
    extractChainebleuVague = Application.Trim(chaine)
End Function

Sub test()
MsgBox extractChainebleuVague([A1])
End Sub

en formule c'est
=extractChainebleuVague(A1)


Regarde la pièce jointe 1184403

Bonsoir Patrick !
Nickel Merci beaucoup !!
Vous m'aviez déjà aidé il y a quelques années déjà ...
Un grand merci à vous Patrick

 

[Armand11]

Bonsoir Patrick !
Nickel Merci beaucoup !!
Vous m'aviez déjà aidé il y a quelques années déjà ...
Un grand merci à vous Patrick

Patrick ? une question :

Vous me conseillerez plus de maîtriser :
a. VBA (en sachant, sauf erreur de ma part, qu'il n'y aura plus de développement dessus)
b. Python
c. POWER BI

Je travaille dans la Comptabilité / Finance / Contrôle de Gestion et conso avec beaucoup de traitements de Datas.
Merci pour votre conseil
Armand

 

[Armand11]

Bonjour,

Je n'ai pas chargé la macro complémentaire pour cette fonction.

Sinon, si votre fichier admet les macros (.xlsm) :

Function RecupChaine(ByVal LaCellule As Range) As String

Dim I As Integer

    RecupChaine = ""
    With LaCellule
         For I = 1 To .Characters.Count
            If .Characters(I, 1).Font.ColorIndex > 1 Then RecupChaine = RecupChaine & Mid(LaCellule.Value, I, 1)
         Next I
    End With
    If Len(RecupChaine) > 0 Then
       Select Case Mid(RecupChaine, 1, 1)
              Case Chr(32), Chr(160)
                   RecupChaine = Mid(RecupChaine, 2)
       End Select
   End If

End Function

Merci Eric !
Je l'applique
Excellente soirée et à bientôt

 

[mrcooll]

essai mon fichier en PJ et fais un retour

 

[Armand11]

Re,

Et le bleu de la police de votre classeur est le RGB(0,0,153) et pas le RGB(0,0,255).

Bonsoir Pomme !
Et merci pour le Feedback ! et la correction couleur ...
Je vais corriger
Excellente soirée POMME

 

[Eric KERGRESSE]

Il faut que le fichier soit .xlsm.

 

[patricktoulon]

une petite amélioration pour supprimer les couleur virant au violet

  If b > r And b > g And (r <= g) Then chaine = chaine & Mid(cel, i, 1) Else chaine = chaine & " "