VBA: texte a changer par des mots dans d'autres cellules

[jcdffr]

Bonjour a tout le monde,

ma première question après des mois de visite sur ce site... jusqu'à présent j'avais toujours trouvé!

j'essaye de recherche un mot dans un texte et si je le trouve, de le remplacer par un autre mot, cad;

Feuil1
A1 est le résumé d'un évenement donc = "Je ne suis pas contet"
contraintes; il y as une plage aléatoire de feuil1 cellules A donc il peut en avoir des milliers

Feuil2
A2 = "Contet"
B2 = "Content"
contraintes; il y as une plage aléatoire de feuil2 cellules A et B donc il peut aussi en avoir des centaines.

chercher le mot (qui ce trouve dans Feuil2!A2)
dans un texte (qui ce trouve dans Feuil1!A1)
le remplacer par le mot (qui ce trouve dans Feuil2!B2)
tout en gardant le reste du texte

(non ce n'est pas que du spell check malheureusement)

et un grand merci d'avance

 

[job75]

Re : VBA: texte a changer par des mots dans d'autres cellules

Bonjour jcfffr, bienvenue sur XLD,

Pas certain d'avoir tout compris, vos explications me paraissant bien compliquées.

A priori on peut utiliser cette petite macro, à coller dans un Module (Alt+F11) :

Sub Remplacer()
Dim cel As Range
'ici on utilise le CodeName des feuilles
For Each cel In Feuil2.Range("A2", Feuil2.[A65536].End(xlUp))
  If cel <> "" Then Feuil1.[A:A].Replace cel, cel.Offset(, 1), xlPart
Next
End Sub

Bien entendu, pour accepter les macros, le fichier doit être enregistré en .xlsm.

A+

 

[job75]

Re : VBA: texte a changer par des mots dans d'autres cellules

Re,

Ah oui il y a aussi l'histoire de la coloration des mots modifiés, ça c'est compliqué.

Pas sûr que ça me passionne, on verra ça demain, à Pâques ou à la Trinité.

A+

 

[laurent950]

Re : VBA: texte a changer par des mots dans d'autres cellules

Bonjour,

Un Petit bout de code tous simple.

Sub test()

Dim F1 As Worksheet
Dim F2 As Worksheet
Dim Txt As String

Set F1 = Worksheets("Feuil1")
Set F2 = Worksheets("Feuil2")

FinF1 = F1.Range("A65536").End(xlUp).Row
FinF2 = F2.Range("A65536").End(xlUp).Row

For i = 2 To FinF1
Txt = F1.Cells(i, 1)
    For j = 2 To FinF2
        If Txt Like "*" & F2.Cells(j, 1) & "*" Then
            Txt = Replace(Txt, F2.Cells(j, 1), F2.Cells(j, 2))
        End If
    Next j
    F1.Cells(i, 2) = Txt
Next i
End Sub

Ps : Si le nombre est vraiment très grand dans le nombre des traitements (Tous passer en variable Tableau) et donc Code a adapeter (Remplace les Cells par un Tableau)

Laurent

 

[jcdffr]

Re : VBA: texte a changer par des mots dans d'autres cellules

Bonjour jcfffr, bienvenue sur XLD,

Pas certain d'avoir tout compris, vos explications me paraissant bien compliquées.

A priori on peut utiliser cette petite macro, à coller dans un Module (Alt+F11) :

Sub Remplacer()
Dim cel As Range
'ici on utilise le CodeName des feuilles
For Each cel In Feuil2.Range("A2", Feuil2.[A65536].End(xlUp))
  If cel <> "" Then Feuil1.[A:A].Replace cel, cel.Offset(, 1), xlPart
Next
End Sub

Bien entendu, pour accepter les macros, le fichier doit être enregistré en .xlsm.

A+

Géniale, merci. c'est magnifique

une petite question; si dans la feuille2 C2 je met PM, peut-il laisser le mot mais ajouter le mot qui ce trouve dans feuil2!B2 DEVANT le résumé dans feuil1!A2, comme par ex.

Avant :
(feuil1 A2) Je suis content du BlackBerry
Calcul:
(feuil2 A2: BlackBerry)
(feuil2 B2: SMARTPHONE)
(feuil2 C2: PM) -Si PM Choisi

Après
(feuil1 A2) SMARTPHONE Je suis content du BlackBerry

la seul différence sera si je ne sélectionne pas PM dans C2 (ou C3, etc), le mot sera remplacer au lieu d'être rajouter devant le résumé) cad;

Avant :
(feuil1 A2) Je suis content du BlackBerry
Calcul:
(feuil2 A2: BlackBerry)
(feuil2 B2: SMARTPHONE)
(feuil2 C2: non) -Si PM PAS Choisi

Après
(feuil1 A2) Je suis content du SMARTPHONE

encore, merci d'avance

 

[job75]

Re : VBA: texte a changer par des mots dans d'autres cellules

Bonjour jcdffr, le forum,

Le problème de coloration des mots modifiés est très intéressant, ça vaut un Like 🙂

Voyez cette macro dans le fichier joint, mais elle est difficile à comprendre :

Sub Remplacer()
Dim F1 As Worksheet, F2 As Worksheet
Dim coul&, gras As Boolean, ital As Boolean, x$
Dim cel As Range, t$, colore As Boolean, n%, i%, deb%
'---paramètres---
Set F1 = Feuil1 'CodeName, à adapter
Set F2 = Feuil2 'CodeName, à adapter
coul = 3 'rouge
gras = True
ital = True
x = Chr(160)
Application.ScreenUpdating = False
'---sécurité---
F1.[A:A].Replace x, " ", xlPart
'---remplacement encadré par Chr(160)---
For Each cel In F2.Range("A2", F2.[A65536].End(xlUp))
  If cel <> "" Then F1.[A:A].Replace cel, x & cel.Offset(, 1) & x
Next
'---coloration des textes entre Chr(160)---
For Each cel In F1.Range("A1", F1.[A65536].End(xlUp))
  If InStr(cel, x) Then
    t = cel & "a"
    cel = Replace(cel, x, "")
    colore = False
    n = 0
    For i = 1 To Len(t)
      If Mid(t, i, 1) = x Then
        colore = Not colore
      Else
        n = n + 1
        If colore Then
          If deb = 0 Then deb = n
        Else
          If deb Then
            With cel.Characters(deb, n - deb).Font
              .ColorIndex = coul
              .Bold = gras
              .Italic = ital
            End With
            deb = 0
          End If
        End If
      End If
    Next
  End If
Next
End Sub

L'astuce consiste à encadrer chaque mot remplacé par 2 espaces insécables de code ANSI 160.

Ensuite on modifie la police des mots ainsi repérés.

PS : j'ai lu rapidement votre post #5, sans le comprendre, j'y répondrai quand j'aurai compris.

A+

 

[job75]

Re : VBA: texte a changer par des mots dans d'autres cellules

Re,

Pour le nouveau problème du post #5 voici la macro :

Sub Remplacer()
Dim F1 As Worksheet, F2 As Worksheet
Dim coul&, gras As Boolean, ital As Boolean, x$, plage As Range
Dim cel As Range, r As Range, t$, colore As Boolean, n%, i%, deb%
'---paramètres---
Set F1 = Feuil1 'CodeName, à adapter
Set F2 = Feuil2 'CodeName, à adapter
coul = 3 'rouge
gras = True
ital = False
x = Chr(160)
Set plage = F2.Range("A2", F2.[A65536].End(xlUp))
Application.ScreenUpdating = False
'---sécurité---
F1.[A:A].Replace x, " ", xlPart
'---analyse des textes à modifier---
For Each cel In F1.Range("A1", F1.[A65536].End(xlUp))
  '---remplacement encadré par Chr(160)---
  For Each r In plage
    If InStr(cel, r) Then
      If r.Offset(, 2) = "PM" Then
        cel = x & r.Offset(, 1) & x & " " & cel
      Else
        cel = Replace(cel, x & r & x, x & r.Offset(, 1) & x)
        cel = Replace(cel, r, x & r.Offset(, 1) & x)
      End If
    End If
  Next
  '---coloration des textes entre Chr(160)---
  If InStr(cel, x) Then
    t = cel & "a"
    cel = Replace(cel, x, "")
    colore = False
    n = 0
    For i = 1 To Len(t)
      If Mid(t, i, 1) = x Then
        colore = Not colore
      Else
        n = n + 1
        If colore Then
          If deb = 0 Then deb = n
        Else
          If deb Then
            With cel.Characters(deb, n - deb).Font
              .ColorIndex = coul
              .Bold = gras
              .Italic = ital
            End With
            deb = 0
          End If
        End If
      End If
    Next
  End If
Next
End Sub

Noter qu'il faut 2 boucles imbriquées.

J'ai conservé le code qui colore les mots modifiés.

Fichier (2).

A+

 

[jcdffr]

Re : VBA: texte a changer par des mots dans d'autres cellules

Re,

Pour le nouveau problème du post #5 voici la macro :

Sub Remplacer()
Dim F1 As Worksheet, F2 As Worksheet
Dim coul&, gras As Boolean, ital As Boolean, x$, plage As Range
Dim cel As Range, r As Range, t$, colore As Boolean, n%, i%, deb%
'---paramètres---
Set F1 = Feuil1 'CodeName, à adapter
Set F2 = Feuil2 'CodeName, à adapter
coul = 3 'rouge
gras = True
ital = False
x = Chr(160)
Set plage = F2.Range("A2", F2.[A65536].End(xlUp))
Application.ScreenUpdating = False
'---sécurité---
F1.[A:A].Replace x, " ", xlPart
'---analyse des textes à modifier---
For Each cel In F1.Range("A1", F1.[A65536].End(xlUp))
  '---remplacement encadré par Chr(160)---
  For Each r In plage
    If InStr(cel, r) Then
      If r.Offset(, 2) = "PM" Then
        cel = x & r.Offset(, 1) & x & " " & cel
      Else
        cel = Replace(cel, x & r & x, x & r.Offset(, 1) & x)
        cel = Replace(cel, r, x & r.Offset(, 1) & x)
      End If
    End If
  Next
  '---coloration des textes entre Chr(160)---
  If InStr(cel, x) Then
    t = cel & "a"
    cel = Replace(cel, x, "")
    colore = False
    n = 0
    For i = 1 To Len(t)
      If Mid(t, i, 1) = x Then
        colore = Not colore
      Else
        n = n + 1
        If colore Then
          If deb = 0 Then deb = n
        Else
          If deb Then
            With cel.Characters(deb, n - deb).Font
              .ColorIndex = coul
              .Bold = gras
              .Italic = ital
            End With
            deb = 0
          End If
        End If
      End If
    Next
  End If
Next
End Sub

Noter qu'il faut 2 boucles imbriquées.

J'ai conservé le code qui colore les mots modifiés.

Fichier (2).

A+

merci infiniment 🙂

 

[job75]

Re : VBA: texte a changer par des mots dans d'autres cellules

Re,

Améliorations avec ce fichier (3) :

- variable t utilisée dès le début ce qui accélère un peu la macro

- variables PM et Police définies à partir des listes de validation en D11 et D12.

A+

 

[jcdffr]

Re : VBA: texte a changer par des mots dans d'autres cellules

merci beaucoup, it works like a dream 🙂