Macro in Word Suchen und Ersetzen

  • #1
S

Sukka

Guest
Ich will ein bestimmter Text bzw. Zeichenfolge
in einem doc nur dann finden und ersetzen,
wenn diese Zeichen einem bestimmten Font haben.
Wie schreibt man das am besten?
Vielen Dank!
 
  • #2
Halli hallo

ich hab hier mal etwas kleines zusammen geschrieben.

Code: 
Sub SuchenErsetzten()

'Hier gibst du das Suchwort ein
Const c_suchwort = hi
'Hier der die Schriftart
Const c_fontname = Times New Roman
'Hier die Schriftgrösse
Const c_fontsize = 16
'Hier ob es Fett ist oder nicht (True oder False)
Const c_fontbold = True
'Hier ob es Kursiv ist oder nicht (True oder False)
Const c_fontitalic = True
'Hier das Wort welches dann anstatt dem alten steht
Const c_ersetzten = hello

Set myrange = ActiveDocument.Content
With myrange.Find
.Text = c_suchwort
.Font.Bold = c_fontbold
.Font.Size = c_fontsize
.Font.Name = c_fontname
.Font.Italic = c_fontitalic
.Execute ReplaceWith:=c_ersetzten, Replace:=wdReplaceAll
End With

End Sub

bei fragen bitte melden ^^

mfg billy

Hinweis: im moment ist es so eingestellt dass ALLE Vorkommen ersetzt werden ^^
 
  • #3
Hi billy,

dann versuch es mal so:
Code: 
Sub SuchenErsetzten()
 ->Hier gibst du das Suchwort ein
  Const c_suchwort = hi
 ->Hier der die Schriftart
  Const c_fontname = Times New Roman
 ->Hier die Schriftgrösse
  Const c_fontsize = 16
 ->Hier ob es Fett ist oder nicht (True oder False)
  Const c_fontbold = True
 ->Hier ob es Kursiv ist oder nicht (True oder False)
  Const c_fontitalic = True
 ->Hier das Wort welches dann anstatt dem alten steht
  Const c_ersetzten = hello

  Set myrange = ActiveDocument.Content
  With myrange.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Font.Bold = c_fontbold
    .Font.Size = c_fontsize
    .Font.Name = c_fontname
    .Font.Italic = c_fontitalic
    .Text = c_suchwort
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = True
    .MatchWholeWord = True
    .Replacement.Text = c_ersetzten
    .Execute Replace:=wdReplaceAll
  End With
End Sub

Gruß Matjes  :)
 
  • #4
aber meine lösung war auch gut :'( oder?
 
  • #5
Hi billy,

war schon ganz gut.  :D Es fehlte nur die Initialisierung und der Schalter für Format (  .Format = True ).

Initialisierung ist wichtig, da sich Find die Einstellungen merkt. Wenn Du dann nochmal Find mit anderen Einstellungen benutzt, findet es eventuell ganz andere Stellen als du wolltest.   ;)

Damit das eingestellte Format bei der Suche berücksichtigt wird, muß der Schalter Format auf True stehen.

Gruß Matjes  :)
 
  • #6
grml

bin ja noch jung und blutig ^^
 
  • #7
Vielen Dank für alle eure guten Bemühungen.
Ihr habt mir gut geholfen, ich danke euch!

Wenn ich noch Probleme beim Integrieren habe melde ich mich.
( hoffentlich bekomme ich das hin)
Der Sinn des Macro soll sein, daß man schnell einen Insellösungsfont
in Unicode konvertieren kann. Dabei geht es darum so ca. 20 nicht
kompatible Zeichen zu ersetzen. Mein jetziges Macro konnte
mit Mischdokumente nicht differenziert genug umgehen.   
Bestimmt kann man das eleganter schreiben als ich es bis
jetzt habe. Am Ende sollte dann alles das was z.B. Times_CSX+ ist
noch in ein Unicode Font umgewandelt werden.

Hier das Macro wie ich es bisher hatte:

Code: 
Sub A_Times_CSX_Unicode()
' Konvertiert Times_CSX+ nach Unicode
' Times_CSX_Unicode Makro erstellt am 12.05.2005 von A42
'
    Dim Zeichen_alt(15) As String
    Dim Zeichen_neu(15) As String
    
    Zeichen_alt(1) = à
    Zeichen_neu(1) = ChrW(257)
    Zeichen_alt(2) = ü
    Zeichen_neu(2) = ChrW(7747)
    Zeichen_alt(3) = å
    Zeichen_neu(3) = ChrW(363)
    Zeichen_alt(4) = õ
    Zeichen_neu(4) = ChrW(7751)
    Zeichen_alt(5) = ã
    Zeichen_neu(5) = ChrW(299)
    Zeichen_alt(6) = ï
    Zeichen_neu(6) = ChrW(7749)
    Zeichen_alt(7) = ñ
    Zeichen_neu(7) = ChrW(7789)
    Zeichen_alt(8) = ó
    Zeichen_neu(8) = ChrW(7693)
    Zeichen_alt(9) = ¤
    Zeichen_neu(9) = ChrW(241)
    Zeichen_alt(10) = â
    Zeichen_neu(10) = ChrW(256)
    Zeichen_alt(11) = ë
    Zeichen_neu(11) = ChrW(7735)
    Zeichen_alt(12) = ¥
    Zeichen_neu(12) = ChrW(209)
    Zeichen_alt(13) = ChrW(230)
    Zeichen_neu(13) = ChrW(362)
    Zeichen_alt(14) = ChrW(228)
    Zeichen_neu(14) = ChrW(664)
    Zeichen_alt(15) = `
    Zeichen_neu(15) =->
    
For I = 1 To 15

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Zeichen_alt(I)
        .Replacement.Text = Zeichen_neu(I)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
    Selection.Find.Execute Replace:=wdReplaceAll
 Next I

End Sub
 
  • #8
Irgendwie habe ich es noch nicht hinbekommen.
Das Macro kann einfach die Finger nicht von
Textstellen lassen die nicht in Times_CSX+ sind.

Die ausschließliche Beschränkung auf Times_CSX+
muß man ihm noch beibringen.

Auch die ersetzten Zeichen sollen alle in Times_CSX+ bleiben.
Erst wenn alles ersetzt ist, erst dann soll er den Font
Times_CSX+ an allen Stellen ändern können/dürfen.

Gruß Sukka
 
  • #9
Hallo Sukka,

probiere mal folgende Version, ob die deinen Wünschen entspricht.

Auch die ersetzten Zeichen sollen alle in Times_CSX+ bleiben.
Erst wenn alles ersetzt ist, erst dann soll er den Font
Times_CSX+ an allen Stellen ändern können/dürfen.
Zum Vergrößern anklicken....
hab ich so verstanden, dass der Font einfach beibehalten werden soll.

Gruß Matjes :)
Code: 
Sub A_Times_CSX_Unicode()
' Konvertiert Times_CSX+ nach Unicode
'
    
  Const c_FontName = Times_CSX+
    
  Dim Zeichen_alt(1 To 15) As String
  Dim Zeichen_neu(1 To 15) As String
  Dim I As Long
  
  Zeichen_alt(1) = à:        Zeichen_neu(1) = ChrW(257)
  Zeichen_alt(2) = ü:        Zeichen_neu(2) = ChrW(7747)
  Zeichen_alt(3) = å:        Zeichen_neu(3) = ChrW(363)
  Zeichen_alt(4) = õ:        Zeichen_neu(4) = ChrW(7751)
  Zeichen_alt(5) = ã:        Zeichen_neu(5) = ChrW(299)
  Zeichen_alt(6) = ï:        Zeichen_neu(6) = ChrW(7749)
  Zeichen_alt(7) = ñ:        Zeichen_neu(7) = ChrW(7789)
  Zeichen_alt(8) = ó:        Zeichen_neu(8) = ChrW(7693)
  Zeichen_alt(9) = ¤:        Zeichen_neu(9) = ChrW(241)
  Zeichen_alt(10) = â:       Zeichen_neu(10) = ChrW(256)
  Zeichen_alt(11) = ë:       Zeichen_neu(11) = ChrW(7735)
  Zeichen_alt(12) = ¥:       Zeichen_neu(12) = ChrW(209)
  Zeichen_alt(13) = ChrW(230): Zeichen_neu(13) = ChrW(362)
  Zeichen_alt(14) = ChrW(228): Zeichen_neu(14) = ChrW(664)
  Zeichen_alt(15) = `:       Zeichen_neu(15) =->
    
  For I = 1 To 15
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Font.Name = c_FontName
      .Replacement.Font.Name = c_FontName
      .Text = Zeichen_alt(I)
      .Replacement.Text = Zeichen_neu(I)
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = True
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
  Next I

End Sub
 
  • #10
Vielen Dank!
Ich glaube damit kann man leben. Die deutschen ü und ö
die ja in einem anderen Font sind, werden nicht mehr angefasst.

Dass Word den Zeichensatz der Zeichen welche er in einem
Font nicht findet eigenständig in einen anderen ändert, scheint
an einer Eigenart von Word oder an einer Einstellung an Word
zu liegen.
Jetzt ist noch das Problem nach dem Umwandeln genau die
Stellen die zuvor in Times_CSX+ waren insgesamt in einen
Unicode-Font umzuwandeln. Dazu braucht man jetzt noch einen
Schritt. Vielleicht fällt dir dazu noch was ein?
Es scheint ja so zu sein, daß es hier Programmierer gibt
welche aus dem Handgelenk wissen wie man so was schreibt.
Für Dinge, bei denen ich Stunden mühevoll by Try und Error
zugebracht hätte. Mir mangelt es auch an der vollen und breiten
wie ausführlichen Kommentierung aller einzelnen Schritte und
Befehlen in voller Länge und Ausführlichkeit welche nötig wäre
diese Dinge auch in meinen unvollkommenen Kopf noch hinein zu
bekommen.
 
  • #11
Hi sukka,

dann probier es doch mal mit dem folgenden Makro. Im Replace wandelt er den Text gleich in den Ziel-Font.

In der Konstanten c_ZielFontName  kannst du den Namen des Ziel-Font ändern. Dort steht jetzt Arial.

Gruß Matjes :)
Code: 
Sub A_Times_CSX_Nach_Arial_Unicode()
' Konvertiert Times_CSX+ nach Unicode
'
    
  Const c_QuellFontName = Times_CSX+
  Const c_ZielFontName = Arial
    
  Dim Zeichen_alt(1 To 15) As String
  Dim Zeichen_neu(1 To 15) As String
  Dim I As Long
  
  Zeichen_alt(1) = à:        Zeichen_neu(1) = ChrW(257)
  Zeichen_alt(2) = ü:        Zeichen_neu(2) = ChrW(7747)
  Zeichen_alt(3) = å:        Zeichen_neu(3) = ChrW(363)
  Zeichen_alt(4) = õ:        Zeichen_neu(4) = ChrW(7751)
  Zeichen_alt(5) = ã:        Zeichen_neu(5) = ChrW(299)
  Zeichen_alt(6) = ï:        Zeichen_neu(6) = ChrW(7749)
  Zeichen_alt(7) = ñ:        Zeichen_neu(7) = ChrW(7789)
  Zeichen_alt(8) = ó:        Zeichen_neu(8) = ChrW(7693)
  Zeichen_alt(9) = ¤:        Zeichen_neu(9) = ChrW(241)
  Zeichen_alt(10) = â:       Zeichen_neu(10) = ChrW(256)
  Zeichen_alt(11) = ë:       Zeichen_neu(11) = ChrW(7735)
  Zeichen_alt(12) = ¥:       Zeichen_neu(12) = ChrW(209)
  Zeichen_alt(13) = ChrW(230): Zeichen_neu(13) = ChrW(362)
  Zeichen_alt(14) = ChrW(228): Zeichen_neu(14) = ChrW(664)
  Zeichen_alt(15) = `:       Zeichen_neu(15) =->
    
  For I = 1 To 15
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Font.Name = c_QuellFontName
      .Replacement.Font.Name = c_ZielFontName
      .Text = Zeichen_alt(I)
      .Replacement.Text = Zeichen_neu(I)
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = True
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
  Next I

End Sub
 
  • #12
vielen Dank.
 
Thema:

Macro in Word Suchen und Ersetzen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.839
Beiträge
707.962
Mitglieder
51.492
Neuestes Mitglied
Janus36
Oben