Trouve les Chaines Characteres Ayant un Mot

Bonjour et par avance Merci.

Je m'en remet a votre ingéniosité qui je sais son nombreux et avéré sur ce Magnifique forum.

En Sélectionnant G3 je voudrais faire ressortir les Chaines de caractères de toutes la colonne E contenant une X dans le tableau

Par avance Merci de votre aide Précieux.

Bien cordialement

Bonjour le forum,

Voir le fichier joint.

Merci mbbp,

ton code en B serait parfait pour très peu d'entrée mais le code serait beaucoup trop long pour le dossier complet.

merci pour ta proposition

Cordialement

pour ne pas alourdir mon dossier je préfère l'extraire par macro car cette action n'est pas systématique

merci mbbp pour ta proposition matricielle

Cordialement

Une idée?

Merci d'avance

Salut Barachoie, mbbp,

quelque chose comme ça?

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tRec, tData()
'
If Not Intersect(Target, Range("G3")) Is Nothing Then
    With Worksheets("TABtoDO")
        iRow = .Range("C:C").Find(Target, lookat:=xlWhole).Row
        For x = 4 To .Cells(iRow, Columns.Count).End(xlToLeft).Column
            If .Cells(iRow, x) = "X" Then
                iIdx = iIdx + 1
                ReDim Preserve tData(iIdx)
                tData(iIdx - 1) = .Cells(6, x)
            End If
        Next
    End With
    '
    iRow = Range("E" & Rows.Count).End(xlUp).Row
    tRec = Range("E3:E" & iRow).Value
    Range("E:E").Font.Color = RGB(0, 0, 0)
    Range("E:E").Interior.Color = xlNone
    For x = 1 To UBound(tRec)
        For y = 0 To UBound(tData) - 1
            iFlag1 = InStr(tRec(x, 1), tData(y))
            If iFlag1 > 0 Then
                iFlag2 = Len(tData(y))
                Range("E" & x + 2).Characters(Start:=iFlag1, Length:=iFlag2).Font.Color = RGB(255, 0, 0)
                Range("E" & x + 2).Interior.Color = RGB(215, 215, 215)
                Exit For
            End If
        Next
    Next
End If
'
End Sub

A+

Merci Curulis57,

c'est rapide Efficace que demander de plus que de saluer ta prouesse !!!!!

Merci d'avoir répondu présent et d'avoir fait part de ton génie.

Cordialement

Avec plaisir!

A+

curulis57 bonjour,

Ton code Marche à merveille et encore Merci

seul petit pb c'est lorsque j'ai qu'une seule entrée

en colonne E c'est à dire seul E3 renseigné

la Macro bug sur For x = 1 To UBound(tRec)

Aurais-tu une idée ???

par avance Merci

Salut Barachoie,

problème réglé!

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tRec, tData()
Dim sData As String
'
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("G3")) Is Nothing Then
    With Worksheets("TABtoDO")
        iRow = .Range("C:C").Find(Target, lookat:=xlWhole).Row
        For x = 4 To .Cells(iRow, Columns.Count).End(xlToLeft).Column
            If .Cells(iRow, x) = "X" Then
                iIdx = iIdx + 1
                ReDim Preserve tData(iIdx)
                tData(iIdx - 1) = .Cells(6, x)
            End If
        Next
    End With
    '
    iRow = Range("E" & Rows.Count).End(xlUp).Row
    Range("E:E").Font.Color = RGB(0, 0, 0)
    Range("E:E").Interior.Color = xlNone
    For x = 1 To iRow
        For y = 0 To UBound(tData) - 1
            iFlag1 = InStr(Cells(x, 5), tData(y))
            If iFlag1 > 0 Then
                iFlag2 = Len(tData(y))
                Range("E" & x).Characters(Start:=iFlag1, Length:=iFlag2).Font.Color = RGB(255, 0, 0)
                Range("E" & x).Interior.Color = RGB(215, 215, 215)
                Exit For
            End If
        Next
    Next
End If
'
Application.ScreenUpdating = True
'
End Sub

A+

Bonjour et Merci Curulis57

ton code est fonctionnel sur la base Test

Simplement sur la base réel E:E = AG:AG ET G3= AP2

Donc le code devient

If Not Intersect(Target, Range("AP2")) Is Nothing Then

ET les E et deviennent AG et là plus rien

dois je faire evoluer le 5 de iFlag1 = InStr(Cells(x, 5), tData(y)) ?????

Merci

yes !!!!! OK pour 33

Merci infiniment Curulis57

Cordialement