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

Armand11 · 22 Novembre 2023

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 · 22 Novembre 2023

Bonjour Armand,

Armand11 à dit:
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 :

VB:

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 · 22 Novembre 2023

Bonjour @Armand11 ,

Pas de macro dans votre classeur joint .

mapomme · 22 Novembre 2023

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 · 22 Novembre 2023

Bonjour,

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

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

VB:

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 · 22 Novembre 2023

Eric KERGRESSE à dit:

Bonjour,

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

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

VB:

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 · 22 Novembre 2023

mapomme à dit:
sylvanu à dit:

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 :

VB:

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

Cliquez pour agrandir...

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 · 22 Novembre 2023

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

VB:

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 · 22 Novembre 2023

patricktoulon à dit:

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

VB:

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 · 22 Novembre 2023

Armand11 à dit:
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 · 22 Novembre 2023

Eric KERGRESSE à dit:

Bonjour,

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

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

VB:

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 · 22 Novembre 2023

essai mon fichier en PJ et fais un retour

Armand11 · 22 Novembre 2023

mapomme à dit:
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 · 22 Novembre 2023

Il faut que le fichier soit .xlsm.

patricktoulon · 22 Novembre 2023

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

VB:

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

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

Armand11

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Eric KERGRESSE

XLDnaute Occasionnel

Armand11

XLDnaute Occasionnel

Pièces jointes

Armand11

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Armand11

XLDnaute Occasionnel

Armand11

XLDnaute Occasionnel

Armand11

XLDnaute Occasionnel

mrcooll

XLDnaute Nouveau

Pièces jointes

Armand11

XLDnaute Occasionnel

Eric KERGRESSE

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Discussions similaires