remplacements caractères avec format ?

Version imprimable

Bonjour,

J'utilise une macro trouvée sur le net qui remplace dans ma feuille certains caractères par des autres qui sont stockés dans les cellules N1 à O1 mais je n'arrive pas à copier les formats de ces cellules .

En fait je voudrais faire apparaitre en gras et rouge ces modifications.
J'aimerais aussi limiter le remplacement aux colonnes E et F .
Malgré mes recherches je ne trouve pas et j'ai besoin de votre aide .....

Ci dessous mon code :
Merci d'avance.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub remplacement() Cells.Replace What:="PVA", Replacement:=[N1], LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Cells.Replace What:="KSC", Replacement:=[M1], LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Cells.Replace What:="RTE", Replacement:=[O1], LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Cells.Replace What:="KMT", Replacement:=[P1], LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End Sub

Bonjour,

Essaie avec

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub remplacement()
Dim MaPlage As Range
 
    With Application.ReplaceFormat.Font
        .ColorIndex = 3
        .FontStyle = "Bold"
    End With
 
    Set MaPlage = Columns("E:F")
    MaPlage.Replace What:="PVA", Replacement:=[N1], LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=True
 
    MaPlage.Replace What:="KSC", Replacement:=[M1], LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=True
 
    MaPlage.Replace What:="RTE", Replacement:=[O1], LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=True
 
    MaPlage.Replace What:="KMT", Replacement:=[P1], LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=True
 
End Sub

Cordialement.

07/06/2012, 16h12
mermauze

Merci gFZT82,

Cela fonctionne mais il faudrait que seuls les caractères qui ont été remplaçés soient en gras et rouge
exemple : PCF KSC V2 STD BRUT

Encore merci de ton aide.

Cordialement
Guy

Mouais :koi:, ça change la donne !
Il me semble plus simple de laisser tomber la méthode Replace.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Base 1
Option Explicit
Sub remplacement()
Dim MaPlage As Range, c As Range
Dim Liste1, Liste2
Dim i As Byte, Deb As Byte, Nb As Byte
    Set MaPlage = Columns("E:F")
    Liste1 = Array("PVA", "KSC", "RTE", "KMT")
    Liste2 = Array([N1], [M1], [O1], [P1])
    For i = 1 To UBound(Liste1)
        Set c = MaPlage.Find(Liste1(i), LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = Replace(c, Liste1(i), Liste2(i))
                Deb = InStr(c, Liste2(i))
                Nb = Len(Liste2(i))
                With c.Characters(Start:=Deb, Length:=Nb).Font
                    .FontStyle = "bold"
                    .ColorIndex = 3
                End With
                Set c = MaPlage.FindNext(c)
            Loop While Not c Is Nothing
        End If
    Next i
End Sub

Cordialement.

Merci gFZT82,

Cela commence a être un peu compliqué pour moi .....
Ma demande initiale était de remplacer parce que je voulais copier le format pour faire ressortir certains mots.
mais on peut simplifier je pense en modifiant seulement le format des mots recherchés dans "liste1".

j'ai essayé de modifier le code dans ce sens (voir ci dessous) mais
cela ne fonctionne pas correctement car la macro boucle sur la ligne
"Set c = MaPlage.FindNext(c)"

Merci encore de ton aide
Cordialement
Guy

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub remplacement1()
 
Dim MaPlage As Range, c As Range
Dim Liste1
Dim i As Byte, Deb As Byte, Nb As Byte
 Set MaPlage = Columns("E")
 
     Liste1 = Array("PVA", "KSC", "RTE", "KMT")
 
    For i = 1 To UBound(Liste1)
        Set c = MaPlage.Find(Liste1(i), LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            Do
                Deb = InStr(c, Liste1(i))
                Nb = Len(Liste1(i))
                With c.Characters(Start:=Deb, Length:=Nb).Font
                    .FontStyle = "bold"
                    .ColorIndex = 3
                End With
                Set c = MaPlage.FindNext(c)
            Loop While Not c Is Nothing
        End If
    Next i
End Sub

Bonjour,

j'ai rajouté la condition c.Address <> FirstAddress pour permettre la sortie de la boucle.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub remplacement1()
Dim MaPlage As Range, c As Range
Dim Liste1
Dim i As Byte, Deb As Byte, Nb As Byte
Dim FirstAddress As String
    Set MaPlage = Columns("E")
    Liste1 = Array("PVA", "KSC", "RTE", "KMT")
    For i = 0 To UBound(Liste1)
        Set c = MaPlage.Find(Liste1(i), LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            FirstAddress = c.Address
            Do
                Deb = InStr(c, Liste1(i))
                Nb = Len(Liste1(i))
                With c.Characters(Start:=Deb, Length:=Nb).Font
                    .FontStyle = "bold"
                    .ColorIndex = 3
                End With
                Set c = MaPlage.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    Next i
End Sub

Cordialement.

08/06/2012, 21h59
mermauze

cela fonctionne impeccablement !!
merci beaucoup et bon weekend

Cordialement
Guy