XL 2016 VBA - Colorer toutes les occurences de mots dans une même ligne ou cellule

rjm · 13 Mars 2020

Bonjour.

Une feuille contient la liste de tous les mots clés à trouver (feuille Sh01): liste évolutive.
Dans une autre feuille (Sh02), j'essaie de colorer tous les mots identiques aux mots clés de la Sh01.

Problème: le mot clé peut apparaître 2 ou 3 fois dans une même ligne (ou cellule), et c'est le premier mot trouvé qui est coloré. Le 2è et 3è mot restent intact.

Code utilisé (cf. PJ):

Sub colorer()
Dim i, a, ligne, derLigne1, derLigne2
derLigne1 = Sh01.Cells(Rows.Count, 1).End(xlUp).Row 'feuille liste
derLigne2 = Sh02.Cells(Rows.Count, 1).End(xlUp).Row 'feuille draft

For i = 1 To derLigne2 'feuille Sh02
a = UCase(Sh02.Cells(i, 1))

For j = 2 To derLigne1 'feuille Sh01, commence à la 2è ligne
ligne = UCase(Sh01.Cells(j, 1))

If InStr(a, ligne) > 0 Then
Sh02.Cells(i, 1).Characters(Start:=InStr(a, ligne), Length:=Len(ligne)).Font.Color = vbRed
End If
Next j
Next i
End Sub

Quelq'un a-t-il une idée?

D'avance, merci.

patricktoulon · 13 Mars 2020

re
et pour lever toute ambiguïté (confusion entre un mot et la dernière syllabe d'un mot )
étant donné que je n'utilisais que l'espace suivant pour chopper aussi le premier left(1)
je modifie ce point et donc
je teste le premier mot avec espace suivant d'abords et le mot entre espace ensuite dans la boucle

VB:

Option Explicit
Sub colorer()
    Dim c As Range, cel As Range, i&, listemot As Range
    With Sheets("liste"): Set listemot = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)): End With
    Application.ScreenUpdating = False
    With Sheets("Draft").UsedRange: .Font.Color = vbBlack: .Font.Bold = False: .Font.Name = "Courier New": End With
    For Each c In listemot.Cells
        With Sheets("Draft").UsedRange
            For Each...

laurent3372 · 13 Mars 2020

Bonjour,

Voici ma solution.
Je me suis amusé au passage à utiliser des noms de variables plus parlants qui améliorent la lisibilité du code.

Cordialement,
--
LR

BOISGONTIER · 13 Mars 2020

Bonjour,

VB:

Sub colorier()
    Set f1 = Sheets("texte")
    Set f2 = Sheets("liste")
    derLigne1 = f1.Cells(Rows.Count, 1).End(xlUp).Row
    derLigne2 = f2.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To derLigne1
        ligneAnalysée = Replace(Replace(Replace(UCase(f1.Cells(i, 1)), ".", " "), ",", " "), "'", " ")
        For j = 2 To derLigne2
            mot = UCase(f2.Cells(j, 1))
            mots = Split(ligneAnalysée, " ")
            p = 1
            For k = LBound(mots) To UBound(mots)
              If mot = mots(k) Then f1.Cells(i, 1).Characters(Start:=p, Length:=Len(mot)).Font.Color = vbRed
              p = p + Len(mots(k)) + 1
            Next k
        Next j
    Next i
End Sub

http://boisgontierjacques.free.fr/fichiers/Cellules/ColorerMots.xls

ligneAnalysée = Replace(Replace(Replace(UCase(f1.Cells(i, 1)), ".", " "), ",", " "), "'", " ") gère la ponctuation (.,')

Boisgontier

jmfmarques · 13 Mars 2020

Bonjour
Bien malin qui pourra répondre avec précision tant que ne seront pas levées certaines ambiguïtés :
1)

Problème

Cliquez pour agrandir...

: le mot clé peut apparaître 2 ou 3 fois dans une même ligne (ou cellule), et c'est le premier mot trouvé qui est coloré. Le 2è et 3è mot restent intact.

Le "premier mot" de quoi ? de chaque cellule ? de chaque ligne ? de l'ensemble des lignes ?
2) comment distingue-t-on les "mots" ? A ma connaissance et sans autre précision, les espaces ne sont pas les seuls séparateurs valables de "mots".

patricktoulon · 13 Mars 2020

bonjour
on peut s'amuser un peu si tu veux
met tes mots en couleur et avec des font différents dans ta sheets("liste") et teste ceci

VB:

Option Explicit
Sub colorer()
   Dim c As Range, cel As Range, i&, listemot As Range
    With Sheets("liste"): Set listemot = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)): End With
    Application.ScreenUpdating = False
    With Sheets("Draft").UsedRange: .Font.Color = vbBlack: .Font.Bold = False: .Font.Name = "Courier New": End With
    For Each c In listemot.Cells
        With Sheets("Draft").UsedRange
            For Each cel In .Cells
                If InStr(cel.Value, c.Text & " ") > 0 Then
                    For i = 1 To Len(cel.Value)
                        If Mid(cel.Value, i, Len(c.Text & " ")) = c.Text & " " Then
                            With cel.Characters(Start:=i, Length:=Len(c.Text & " ")).Font
                                .Color = c.Font.Color
                                .FontStyle = "Gras italique"
                                .Name = c.Font.Name
                                'etc....
                                'etc....
                            End With
                        End If
                    Next
                End If
            Next
        End With
    Next
End Sub

vue du sheets liste

démo du résultat

patricktoulon · 13 Mars 2020

re
et pour lever toute ambiguïté (confusion entre un mot et la dernière syllabe d'un mot )
étant donné que je n'utilisais que l'espace suivant pour chopper aussi le premier left(1)
je modifie ce point et donc
je teste le premier mot avec espace suivant d'abords et le mot entre espace ensuite dans la boucle

VB:

Option Explicit
Sub colorer()
    Dim c As Range, cel As Range, i&, listemot As Range
    With Sheets("liste"): Set listemot = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)): End With
    Application.ScreenUpdating = False
    With Sheets("Draft").UsedRange: .Font.Color = vbBlack: .Font.Bold = False: .Font.Name = "Courier New": End With
    For Each c In listemot.Cells
        With Sheets("Draft").UsedRange
            For Each cel In .Cells
                If InStr(cel.Value, c.Text & " ") > 0 Then
                    For i = 1 To Len(cel.Value)
                        If Left(cel.Value, Len(c.Value & " ")) = c.Text & " " Then
                            With cel.Characters(Start:=1, Length:=Len(c.Text & " ")).Font
                                .Color = c.Font.Color
                                .FontStyle = "Gras italique"
                                .Name = c.Font.Name
                            End With
                        End If
                       
                        If Mid(cel.Value, i, Len(" " & c.Text & " ")) = " " & c.Text & " " Then
                            With cel.Characters(Start:=i, Length:=Len(" " & c.Text & " ")).Font
                                .Color = c.Font.Color
                                .FontStyle = "Gras italique"
                                .Name = c.Font.Name
                                'etc....
                                'etc....
                            End With
                        End If
                    Next
                End If
            Next
        End With
    Next
End Sub

jmfmarques · 13 Mars 2020

mot avec espace suivant d'abords et le mot entre espace

Et les mots dont la dernière lettre est suivie d'une ponctuation ? Et ceux précédés ou suivis d'un tiret ? Et ceux (ce seront les pires) qui suivent une apostrophe ?

patricktoulon · 13 Mars 2020

re
bonjour @jmfmarques
1° suivi d'un tiret c'est un mot composé ce n'est donc pas un des mot recherché c'est une syllabe
(sauf language spécial"ex:informatique")a adapter donc au besoins (texte particulier)

2°la ponctuation c'est quoi "?!:.,etc..) ben tu les ajoute et pourquoi pas faire un select case

et pourquoi pas faire un regex global de replacement et colorer tout les matchs pointés en un seul coup
bref solutions il y a

jmfmarques · 13 Mars 2020

Bien dit ("dit", hein ...). On en reparlera lorsque tu auras déclaré avoir "fini".
PS :

suivi d'un tiret c'est un mot composé ce n'est donc pas un des mot recherché c'est une syllabe

Ah .... une "syllabe", hein ... hein ??? (inquiétant).

rjm · 18 Mars 2020

Bonjour BOISGONTIER

Il me semble que ta solution a été codée naturellement !
J'aimerais bien avoir cette logique un jour.

Mille merci,

rjm · 18 Mars 2020

Bonjour à tous.

Merci bien pour toutes vos réponses.
J'ai eu beaucoup de plaisir à les lire vos codes et cela m'a bien aidé en tout cas.

Cordialement.

XL 2016 VBA - Colorer toutes les occurences de mots dans une même ligne ou cellule

rjm

XLDnaute Nouveau

Pièces jointes

patricktoulon

laurent3372

XLDnaute Impliqué

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

jmfmarques

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

jmfmarques

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

jmfmarques

XLDnaute Accro

rjm

XLDnaute Nouveau

rjm

XLDnaute Nouveau

Discussions similaires