Word-VBA suchen/ersetzen

  • #1
I

Ixus

Guest
Hallo allerseits,
vielleicht kann mir jemand helfen:

Ein Text der durch dynamische Bausteine erstellt wurde, soll auszugsweise einem Empfänger zur Verfügung gestellt werden. Alle Textbausteine die anschließend entfernt werden müssen, habe ich am Anfang bzw. Ende mit einem + Zeichen versehen. Das folgende Makro:

Sub AutoNew()

Selection.Paste

Application.ScreenUpdating = True
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.Format = True
.MatchWildcards = True

.Text = (+)(*)(+)
.Replacement.Font.Name = Arial
.Replacement.Font.Size = 11
.Replacement.Font.Color = wdColorAutomatic
.Replacement.Text = pp. ...
.Execute Replace:=wdReplaceAll

Application.ScreenUpdating = True
End With

End Sub


kopiert mir den Originaltext in ein neues Dokument, sucht sich anschließend alle mit + markierten Stellen und ersetzt diese durch pp. .... Das funktioniert bis hierher auch ganz ordentlich. Mein Problem besteht darin, dass wenn mehrere zu entfernende Textteile im Originaltext gefunden werden, dann werden diese Teile auch mehrere Male durch pp. ... ersetzt. D.h. im Text steht dann mehrere Male hintereinander pp. ..., wo es aber nur 1x autauchen sollte.
Hat jemand eine Lösung????

Vielen Dank im voraus!!!

Ixus
 
  • #2
Ola,

setz noch eine Suchen und Ersetzen Schleife dran, die immer ppp. ... ppp. ... durch ein pp. ... ersetzt dann bleibt immer eines übrig, falls mehrere nacheinander stehen.
 
  • #3
Hallo,
zunächst einmal Danke für Deine schnelle Antwort.
Aber ich muss gestehen mir ist nicht klar, wie ich die Schleife setzen soll,
denn wenn ich pp. ... durch pp. ... mittels einer Wildcard ersetze,
dann bin ich doch schlussendlich genauso weit wie vorher oder irre ich
mich jetzt?

Irgendwie bräuchte ich eine Prüfroutine, die mir mehrere pp. ... im Text findet, markiert und durch 1x
pp. ... ersetzt, aber wie ich so etwas zusammendrösele ist mir vollkommen unklar!
Hattest Du so etwas gemeint????

Liebe Grüße
Ixus
 
  • #4
Nachtrag:
Ach so, ich hatte vergessen zu erwähnen, dass die pp. ... auf mehrere Zeilen untereinander verteilt sind:
Bsp.:

Text

pp. ...

pp. ...

Text


pp. ...

Text

Gruß
Ixus
 
  • #5
zweite Suchschleife

Code: 
With ActiveDocument.Range.Find
    .Format = True
    .MatchWildcards = True
    
    .Text = pp. ...  & vbCrLf & vbCrLf & pp. ... 
    .Replacement.Font.Name = Arial
    .Replacement.Font.Size = 11
    .Replacement.Font.Color = wdColorAutomatic
    .Replacement.Text = pp. ... 
    .Execute Replace:=wdReplaceAll
  
  Application.ScreenUpdating = True
End With

Gruß Matjes :)
 
  • #6
Ola,

nur der Vollständigkeit halber: Ja, so ähnlich. Wenn gleichartige Textobjekte merhfach hintereinander auftauchen und davom immer eines übrig bleiben soll, dann nimm immer zwei und ersetze durch eines. Wenn das nicht reicht,weil drei hintereinander auftauchen, dann passiert das eben zwei mal: 3 -> 2 -> 1
 
  • #7
:D Vielen, vielen, vielen Dank an Euch Beide!!!!!

Das klappt ganz prima!!!!! :D

Das war prompte und kompetente Hilfe!!!!

Allerherzlichste Grüße
Ixus
 
  • #8
und hier noch eine Sub  ;)

Gruß Matjes :)
Code: 
Sub Word_doppelteTexteErsetzen()
'***
'*** Der Suchtext wird im aktuellen Dokument gesucht.
'***
'*** Gibt es zwei Fundstellen, zwischen denen nur Steuer/Leerzeichen (ascii 0-32) vorhanden sind,
'*** wird der Text vom Anfang der ersten Fundstelle bis zum Anfang der zweiten Fundstelle
'*** gelöscht.

  Const c_SUCHTEXT = pp. ...
  
  Dim doc As Document, r As Range
  Dim FundSt1_start As Long, FundSt2_start As Long
  Dim s As String, b_Loeschen As Boolean, x As Long, l_asc As Long
  
  
  Set doc = ActiveDocument
  Set r = doc.Content
  
 ->1. Fundstelle
  With r.Find
    .ClearFormatting
    .Format = False
    .Forward = True
    .Text = c_SUCHTEXT
    If Not .Execute() Then GoTo AUFRAEUMEN-> nichts gefunden -> Ende
    FundSt1_start = .Parent.Start
  End With

 ->für alle c_Suchtext
  Do
    Set r = doc.Range(Start:=FundSt1_start + Len(c_SUCHTEXT), End:=doc.Content.End)
  
   ->2. Fundstelle
    With r.Find
      .ClearFormatting
      .Format = False
      .Forward = True
      .Text = c_SUCHTEXT
      If Not .Execute() Then GoTo AUFRAEUMEN-> nichts gefunden -> Ende
      FundSt2_start = .Parent.Start
    End With
  
    
    b_Loeschen = True
    Set r = doc.Range(Start:=FundSt1_start, End:=FundSt2_start)
    For x = 1 To r.Characters.Count
      If x > Len(c_SUCHTEXT) Then
        l_asc = Asc(r.Characters(x))
        Select Case l_asc
          Case 1 To 32:
          Case Else:
           b_Loeschen = False: Exit For
        End Select
      End If
    Next
    
    r.Select
    If b_Loeschen Then
     ->Text loeschen von Anf 1. Fundst bis Anf 2. Fundstelle
      r.Text = 
    Else
     ->zweite Fundstelle wird erste
      FundSt1_start = FundSt2_start
    End If
  
  Loop
AUFRAEUMEN:
  Set r = Nothing: Set doc = Nothing
End Sub
 
  • #9
Hallo Matjes,

das ist ja suuper, so wie es aussieht sind alle meine Probleme für
das Textprodukt mit Deiner letzten SUB gelöst!!

***Dir mal ein Bierchen->rüber reich! - Lass Dirs schmecken!!***

Dankefein!!!
Ixus
 
Thema:

Word-VBA suchen/ersetzen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.836
Beiträge
707.957
Mitglieder
51.489
Neuestes Mitglied
DonMartin
Oben