Vba tekst vervangen met tekst in kleur

[Tijsss]

Beste mensen,

Ik wil in word een bepaalde tekst (test1 en test2) vervangen met een andere tekst (appel en peer), zie hieronder. Alleen wil ik bv appel vervangen van de standaard kleur zwart in bv rood en peer vervangen van zwart in oranje.

Is dit mogelijk en de vraag is hoe?

Gr. Tijs

Sub VervangOveral()
Dim aRange As Range, bytN As Byte

On Error GoTo ErrorTrap_VervangOveral
bytN = 1

While bytN <= ActiveDocument.StoryRanges.Count
Set aRange = ActiveDocument.StoryRanges(bytN)

aRange.Find.ClearFormatting
aRange.Find.Replacement.ClearFormatting
With aRange.Find
.Text = "Test1"
.Replacement.Text = "appel"
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
aRange.Find.Execute Replace:=wdReplaceAll

aRange.Find.ClearFormatting
aRange.Find.Replacement.ClearFormatting
With aRange.Find
.Text = "Test2"
.Replacement.Text = "peer"
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
aRange.Find.Execute Replace:=wdReplaceAll
bytN = bytN + 1
Wend
Exit Sub

ErrorTrap_VervangOveral:
bytN = bytN + 1
Resume

End Sub

 

[OctaFish]

Begin eens met je code op te maken met de CODE knop ( # ). Dan is hij leesbaar.

 

[Tijsss]

Beste Octa,

Op deze manier?

Sub VervangOveral()
 Dim aRange As Range, bytN As Byte

 On Error GoTo ErrorTrap_VervangOveral
 bytN = 1

 While bytN <= ActiveDocument.StoryRanges.Count
 Set aRange = ActiveDocument.StoryRanges(bytN)

 aRange.Find.ClearFormatting
 aRange.Find.Replacement.ClearFormatting
 With aRange.Find
 .Text = "Test1"
 .Replacement.Text = "appel"
 .Wrap = wdFindContinue
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 aRange.Find.Execute Replace:=wdReplaceAll

 aRange.Find.ClearFormatting
 aRange.Find.Replacement.ClearFormatting
 With aRange.Find
 .Text = "Test2"
 .Replacement.Text = "peer"
 .Wrap = wdFindContinue
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 aRange.Find.Execute Replace:=wdReplaceAll
 bytN = bytN + 1
 Wend
 Exit Sub

 ErrorTrap_VervangOveral:
 bytN = bytN + 1
 Resume

 End Sub

 

[OctaFish]

Dat is inderdaad veel beter . Wat mij betreft had je het eerste bericht aan mogen passen, want die blijft nu een halve meter te lang .
Ik zou zeggen: neem de macro op met opmaak erbij, want dat kan dus ook. Je hebt nu alleen de tekst vervangen. Je krijgt dan zoiets:

        With aRange.Find
            With .Replacement
                With .Font
                    .Size = 12
                    .Bold = True
                    .Outline = True
                    .Color = 192
                End With
                .Text = "appel"
            End With
            .Text = "Test1"
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With

 

[Tijsss]

Het is gelukt! Super bedankt voor je hulp.

 

[OctaFish]

Mag je de vraag nog op <Opgelost> zetten.