mettre en couleur une partie de texte

CB60

XLDnaute Barbatruc
Bonjour

Je cherche à faire une macro pour colorier entre deux caractères, mais je ne trouve pas la syntaxe.

Code:
Sub couleur()
  mot = "^« *"
  mot1 = "* »$"
  mot2 = mot & mot1
  For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot2))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot2)).Font.ColorIndex = 3
  Next c
End Sub
si vous avez une idée!!
Merci
 

Modeste

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Salut Bruno :)

Mais quels sont donc ces caractères que tu cherches? Les valeurs de mot et mot1 me laissent perplexe :eek:

Quoi qu'il en soit, Instr devrait te donner la position du premier, ainsi que la position du second. Au départ de la position du premier, une soustraction te fournirait la "longueur" (le len(mot2) que tu utilises me paraît compliqué à calculer :confused:)
 

CB60

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Bonjour
les caracteres recherchés sont en bleu:
« et », je veux colorier ce qui se trouve à l'interieur, les autres caractéres, je les ai trouvé sur google le ^ voulait dire qui commence et le $ voulais dire qui termine.
 

Modeste

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Re,

J'ai peut-être compris de travers, mais que donnerait:
VB:
Sub couleur()
    For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
        deb = InStr(1, c, "«", 1)
        fin = InStr(1, c, " »", 1)
        longueur = fin - deb
        If deb > 0 And fin > 0 Then c.Characters(Start:=deb + 1, Length:=fin - deb - 2).Font.ColorIndex = 3
    Next c
End Sub
 

Modeste

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Re²,

Tu sais ce qu'on dit souvent aux nouveaux arrivants: "un extrait de ton fichier aiderait à mieux comprendre et permettrait de tester, etc." :)

Il y a effectivement différents scénarios possible:
- plusieurs "paires" de '«' et '»' dans une même cellule (et dans ce cas, il faudrait mettre en couleur plusieurs sous-chaînes, semble-t-il?)
- des '«' ou '»' sans leur tendre moitié, ça n'arrivera jamais?
- il faudrait préciser aussi le volume à traiter: s'il n'y a qu'une vingtaine de cellules, on peut se permettre des choses plus "bourrines" que s'il y en a 30.000
 

CB60

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Re
Oui Modeste je suis d'accord pour le fichier, je demande souvent lorsque j'essai de répondre sur le Forum, mais la c'etait plus, pour savoir, si je partais sur le bon critère de boucle, je vais me creuser un peu la tête, avant d'avoir du tout cuit, tu a déjà réussi à solutionner une grande partie de mon soucis.
(PS: je suis nouveau dans le questionnement, ça doit être pour ça que j'ai pas mis de fichier;))
Merci encore
 

Modeste

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

(PS: je suis nouveau dans le questionnement, ça doit être pour ça que j'ai pas mis de fichier;))
Ce n'était pas un reproche :) simplement la présence de plusieurs sous-chaîne n'avait pas été évoquée (et je ne l'avais pas imaginée!) et créer un fichier test j'ai pu le faire (si, si! ;))

Sur ce tout petit fichier test, ceci fonctionne
VB:
Sub couleur2()
    For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
        For ch = 1 To Len(c)
        If Mid(c, ch, 1) = "«" Then
            deb = ch
            fin = ch
            Do
                fin = fin + 1
                If Mid(c, fin, 1) = "»" Then
                    c.Characters(Start:=deb + 1, Length:=fin - deb - 1).Font.ColorIndex = 3
                    deb = fin
                    Exit Do
                End If
            Loop While fin < Len(c)
        End If
        Next ch
    Next c
End Sub

Mais sur un gros volume, ça risque de "chauffer"

... je vais au jardin! :)
 

CB60

XLDnaute Barbatruc
Re : mettre en couleur une partie de texte

Re

Ben j'aurais pas trouvé seul!!!!
Je ne l'ai pas pris pour un reproche, je suis entièrement d'accord avec le fait de joindre un fichier.
Merci et Bon jardinage.
 

VIARD

XLDnaute Impliqué
Re : mettre en couleur une partie de texte

Bonjour CB60, Modeste et à tous

Cette histoire m'a perturbé pendant un moment.

voici ma solution.

Code:
Sub MiseCouleurTexte()
Dim Texte$
Dim J%, i%, P%, Nb%
Dim Terme(), Clor(), Terme2$

Application.ScreenUpdating = False
Nb = Range("B65000").End(xlUp).Row
Terme = Array("", "With", "Sub", "For", "Next", "End", "Then", "Select")
Clor = Array("", 4, 3, 5, 5, 4, 5, 3)
'-------- Traitement -------
For J = 1 To 7
    Terme2 = Terme(J) & " "
    For i = 1 To Nb
        Texte = Range("B" & i).Value
        P = InStr(UCase(Texte & " "), UCase(Terme2))
        If P > 0 Then Range("B" & i).Characters(Start:=P, Length:=Len(Terme(J))).Font.Color = Couleur(Clor(J))
        If P > 0 Then Range("B" & i).Characters(Start:=P, Length:=Len(Terme(J))).Font.Bold = True
    Next i
Next J
Application.ScreenUpdating = True
End Sub

et avec la fonction couleur

Code:
Function Couleur(c1) As Long
Select Case c1
    Case 1: Couleur = RGB(255, 255, 255) 'Blanc
    Case 2: Couleur = RGB(0, 0, 0) 'noir
    Case 3: Couleur = RGB(255, 0, 0) 'rouge
    Case 4: Couleur = RGB(0, 255, 0) 'vert
    Case 5: Couleur = RGB(0, 0, 255) 'bleu
    Case 6: Couleur = RGB(255, 255, 0) 'jaune
    Case 8: Couleur = RGB(0, 255, 255) 'cyan
    Case 10: Couleur = RGB(0, 120, 0) 'vert foncé
    Case 23: Couleur = RGB(0, 120, 255) 'bleu clair
    Case 46: Couleur = RGB(255, 100, 0) 'orange
End Select
End Function

Mais le module précédent ne permet pas de traiter 2 mots identique sur la même ligne.

Une autre version.

Code:
Sub MiseCouleurTexte(Mot1, Pos1, Col)
Dim Texte$
Dim j%, i%, P&, Nb%, Nb1%, K%
Dim Terme(), Terme2$

Sheets("Feuil2").Activate
Application.ScreenUpdating = False
'----- dernière ligne de la plage ---------
Nb = Sheets("Feuil2").Cells(65536, Col).End(xlUp).Row
'-------------------------
'MsgBox "Nb= " & Nb & "   Pos1= " & Pos1 & "    Mot1= " & Mot1
If Mot1 = "" Then Exit Sub
Terme = Array("", "", ".", ",")
'-------- Traitement -------
For j = 1 To 3
    Terme2 = Mot1 & Terme(j) & " "
    For i = Pos1 To Nb + 1
        Texte = Cells(i, Col).Value
        Nb1 = Len(Texte)
        For K = 1 To Nb1
            P = InStr(K, Texte & " ", Terme2, 1)
'            If P <> 0 Then MsgBox "P= " & P & "   Nb1= " & Nb1 & "    terme2= " & Terme2
            If P > 0 Then Cells(i, Col).Characters(Start:=P, Length:=Len(Terme(j) & Mot1)).Font.Color = RGB(255, 0, 0)
            If P > 0 Then Cells(i, Col).Characters(Start:=P, Length:=Len(Terme(j) & Mot1)).Font.Bold = True
        Next K
    Next i
Next j
Application.ScreenUpdating = True
End Sub

J'espère que ceci t'aidera à trouver ton bonheur.

A+ Jean-Paul
 

Discussions similaires

Statistiques des forums

Discussions
294 210
Messages
1 936 894
Membres
188 098
dernier inscrit
flow77