Makro in Word zum Suchen und Ersetzten?

Dieses Thema Makro in Word zum Suchen und Ersetzten? im Forum "Microsoft Office Suite" wurde erstellt von Dani83, 20. Mai 2005.

Thema: Makro in Word zum Suchen und Ersetzten? Hallo Zusammen, habe folgendes Problem: Brauche ein Makro das mir in einem Text in dem HTML-Codes vorkommen, diese...

  1. Hallo Zusammen,

    habe folgendes Problem: Brauche ein Makro das mir in einem Text in dem HTML-Codes vorkommen, diese raussucht und Ersetzt!

    Beispiel: blablablablabla <u>Hallo</u>

    Ergebnis: blablablablabla Hallo

    Das Problem ist das es absolut variabel sein muss!


    Danke für Eure Hilfe!!!!
     
  2. Hi Dani83,

    also möchtest einen Makro für Word.

    - gesamten Text durchsuchen nach <u>irgendwas</u>
    - gefundene Stellen ersetzen durch unterstrichenes irgendwas
    - dabei ggf. überflüssige Leerstellen entfernen

    So richtig ?

    Gruß Matjes :)
     
  3. Das könnte dann so aussehen:
    Code:
    Sub HtmlTagsDurchUnterstrichenenTextErsetzen()
    
      Const c_TAG_ANFANG = <u>
      Const c_TAG_ENDE = </u>
      
      Dim doc As Document, s_Text As String, l_PosAnf As Long
      Dim l_TagStart_anf As Long, l_TagStart_end As Long
      Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
      
      
      Set doc = ActiveDocument
      
      l_PosAnf = 0
      
      Do
       ->Start-Tag suchen
        Selection.Start = l_PosAnf
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .MatchWholeWord = False
          .MatchCase = False
          .Wrap = wdFindStop
         ->nichts mehr gefunden ?
          If .Execute(FindText:=c_TAG_ANFANG) = False Then Exit Do
        End With
        
       ->Position merken
        l_TagStart_anf = Selection.Start
        l_TagStart_end = Selection.End
        
       ->Stop-Tag suchen
        Selection.Start = l_TagStart_end
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .Forward = True
          .MatchWholeWord = False
          .MatchCase = False
          .Wrap = wdFindStop
         ->nichts mehr gefunden ?
          If .Execute(FindText:=c_TAG_ENDE) = False Then
            doc.Range(l_TagStart_anf, l_TagStart_end).Select
            MsgBox (Hier fehlt das STOP-Tag.)
            Exit Do
          End If
        End With
            
       ->Position merken
        l_TagStop_anf = Selection.Start
        l_TagStop_end = Selection.End
        
       ->Fundstelle bearbeiten
        
       ->Stop-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStop_anf, _
                  End:=l_TagStop_end).Text = 
        
       ->Tag-Text bearbeiten
        s_Text = doc.Range(Start:=l_TagStart_end, _
                             End:=l_TagStop_anf).Text
       ->Leerzeichen an Anfang  und Ende entfernen
        s_Text = Trim(s_Text)
        doc.Range(Start:=l_TagStart_end, _
                    End:=l_TagStop_anf).Text = s_Text
       ->unterstreichen
        doc.Range(Start:=l_TagStart_end, _
                    End:=l_TagStart_end + Len(s_Text)).Underline = True
                                    
       ->Start-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStart_anf, _
                  End:=l_TagStart_end).Text = 
        
       ->Selectionsanfang auf letzte Fundstelle
        l_PosAnf = l_TagStart_anf + 1
    
      Loop
      Set doc = Nothing
    
    End Sub
    Gruß Matjes :)
     
  4. Danke schön!!!

    Werd das Makro jetzt direkt mal testen!
     
  5. Makro klappt super! Danke schön!

    Nächstes Problem:

    Jetzt brauch ich ein Makro, das genau andersrum läuft...
    ...also von Formatierung nach HTML-Code!

    Danke jetzt schonmal für eure Hilfe!
     
  6. Hi Dani83,

    Das ist leichter gesagt als getan. Woran soll der Makro denn erkennen, welchen Text er in <u> </u> setzen soll ?

    Gruß Matjes :)
     
  7. Also das Makro soll so funktionieren: es soll einen beliebigen Text auf abweichende Formatierung durchsuchen. Fettgedrucktes soll dann in <b>...</b> stehen, Unterschrichenes in <u>...</u> und dann eben unformatiert (Format wie der restliche Text)!

    Wäre super wenn ihr mir helfen könntet...!!!
    Denn ich bin total :-\
     
  8. Hallo Dani83,

    ich hab dir jetzt ein Pärchen geschrieben:
    HtmlTags_u_InUnterstrichen_HtmlTags_b_InFett
    UnterstrichenInHtmlTags_u_FettInHtmlTags_b

    Pack den unten angegebenen Code in ein Modul.

    Der alte Makro ist darin enthalten, aber etwas modifiziert.

    Gruß Matjes :)
    Code:
    Sub HtmlTags_u_InUnterstrichen_HtmlTags_b_InFett()
      Application.ScreenUpdating = False
      Call HtmlTags_u_DurchUnterstrichenenTextErsetzen
      Call HtmlTags_b_DurchFettenTextErsetzen
      Selection.Collapse
      Application.ScreenUpdating = True
    End Sub
    Sub UnterstrichenInHtmlTags_u_FettInHtmlTags_b()
      Application.ScreenUpdating = False
      Call UnterstrichenenTextInHtmlTags_u_Wandeln
      Call FettenTextInHtmlTags_b_Wandeln
      Selection.Collapse
      Application.ScreenUpdating = True
    End Sub
    Private Function HtmlTags_b_DurchFettenTextErsetzen()
    
      Const c_TAG_ANFANG = <b>
      Const c_TAG_ENDE = </b>
      
      Dim doc As Document, s_Text As String, l_PosAnf As Long
      Dim l_TagStart_anf As Long, l_TagStart_end As Long
      Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
      Dim l_Bold_Anf As Long, l_Bold_End As Long, x As Long
      
      Set doc = ActiveDocument
      
      l_PosAnf = 0
      
      Do
       ->Start-Tag suchen
        Selection.Start = l_PosAnf
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = False
          .Forward = True
          .Wrap = wdFindStop
          .Text = c_TAG_ANFANG
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          If .Execute() = False Then Exit Do->nichts mehr gefunden ?
        End With
        
       ->Position merken
        l_TagStart_anf = Selection.Start
        l_TagStart_end = Selection.End
        
       ->Stop-Tag suchen
        Selection.Start = l_TagStart_end
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = False
          .Forward = True
          .Wrap = wdFindStop
          .Text = c_TAG_ENDE
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          If .Execute() = False Then->nichts mehr gefunden ?
            doc.Range(l_TagStart_anf, l_TagStart_end).Select
            MsgBox (Hier fehlt das STOP-Tag.)
            Exit Do
          End If
        End With
            
       ->Position merken
        l_TagStop_anf = Selection.Start
        l_TagStop_end = Selection.End
        
       ->Fundstelle bearbeiten
        
       ->Stop-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStop_anf, _
                  End:=l_TagStop_end).Text = 
        
       ->Leerzeichen am Anfang nicht fett
        l_Bold_Anf = l_TagStart_end
        For x = l_TagStart_end To l_TagStop_anf
          l_Bold_Anf = x
          If doc.Range(x, x + 1).Text <>   Then: Exit For
        Next
        
       ->Leerzeichen am Ende nicht fett
        l_Bold_End = l_TagStop_anf
        For x = l_TagStop_anf To l_Bold_Anf Step -1
          l_Bold_End = x
          If doc.Range(x - 1, x).Text <>   Then Exit For
        Next
        
       ->fett setzen
        If l_Bold_Anf < l_Bold_End Then
          doc.Range(Start:=l_Bold_Anf, _
                      End:=l_Bold_End).Bold = True
        End If
        
       ->Start-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStart_anf, _
                  End:=l_TagStart_end).Text = 
        
       ->Selectionsanfang auf letzte Fundstelle
        l_PosAnf = l_TagStart_anf + 1
    
      Loop
      Set doc = Nothing
    
    End Function
    Private Function HtmlTags_u_DurchUnterstrichenenTextErsetzen()
    
      Const c_TAG_ANFANG = <u>
      Const c_TAG_ENDE = </u>
      
      Dim doc As Document, s_Text As String, l_PosAnf As Long
      Dim l_TagStart_anf As Long, l_TagStart_end As Long
      Dim l_TagStop_anf As Long, l_TagStop_end As Long, s_tmp As String
      Dim l_Underline_Anf As Long, l_Underline_End As Long, x As Long
      
      Set doc = ActiveDocument
      
      l_PosAnf = 0
      
      Do
       ->Start-Tag suchen
        Selection.Start = l_PosAnf
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = False
          .Forward = True
          .Wrap = wdFindStop
          .Text = c_TAG_ANFANG
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          If .Execute() = False Then Exit Do->nichts mehr gefunden ?
        End With
        
       ->Position merken
        l_TagStart_anf = Selection.Start
        l_TagStart_end = Selection.End
        
       ->Stop-Tag suchen
        Selection.Start = l_TagStart_end
        Selection.End = doc.Content.End
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = False
          .Forward = True
          .Wrap = wdFindStop
          .Text = c_TAG_ENDE
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          If .Execute() = False Then->nichts mehr gefunden ?
            doc.Range(l_TagStart_anf, l_TagStart_end).Select
            MsgBox (Hier fehlt das STOP-Tag.)
            Exit Do
          End If
        End With
            
       ->Position merken
        l_TagStop_anf = Selection.Start
        l_TagStop_end = Selection.End
        
       ->Fundstelle bearbeiten
        
       ->Stop-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStop_anf, _
                  End:=l_TagStop_end).Text = 
        
       ->Leerzeichen am Anfang nicht mitunterstreichen
        l_Underline_Anf = l_TagStart_end
        For x = l_TagStart_end To l_TagStop_anf
          l_Underline_Anf = x
          If doc.Range(x, x + 1).Text <>   Then: Exit For
        Next
        
       ->Leerzeichen am Ende nicht mitunterstreichen
        l_Underline_End = l_TagStop_anf
        For x = l_TagStop_anf To l_Underline_Anf Step -1
          l_Underline_End = x
          If doc.Range(x - 1, x).Text <>   Then Exit For
        Next
        
       ->unterstreichen
        If l_Underline_Anf < l_Underline_End Then
          doc.Range(Start:=l_Underline_Anf, _
                      End:=l_Underline_End).Underline = True
        End If
        
       ->Start-Tag gegen  ersetzen
        doc.Range(Start:=l_TagStart_anf, _
                  End:=l_TagStart_end).Text = 
        
       ->Selectionsanfang auf letzte Fundstelle
        l_PosAnf = l_TagStart_anf + 1
    
      Loop
      Set doc = Nothing
    
    End Function
    Private Function FettenTextInHtmlTags_b_Wandeln()
    ' im gesamten Text des aktiven Documents wird
    ' fetter Text in Tags <b>...</b> eingefaßt und
    ' der fette Text in normalen Text gewandelt.
    
    
      Const c_TAG_ANFANG = <b>
      Const c_TAG_ENDE = </b>
      
      Dim doc As Document
      Dim l_Start_anf As Long, l_Start_end As Long
      Dim l_PosEnd As Long, l_pos As Long
    
      Set doc = ActiveDocument
      
     ->Suchbereichsende setzen
      l_PosEnd = doc.Content.End
      
      Do
       ->Formatierung Fett suchen, vom Ende rückwärts
        Selection.Start = doc.Content.Start
        Selection.End = l_PosEnd
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = True
          .Forward = False
          .Wrap = wdFindStop
          .Text = ^?
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          .Font.Bold = True
          If .Execute() = False Then Exit Do->nichts gefunden ?
        End With
        
       ->Position merken
        l_Start_anf = Selection.Start
        l_Start_end = Selection.End
        
       ->Zeichen davor auch unterstrichen ?
        l_pos = l_Start_anf - 1
        Do
          If l_pos < 0 Then Exit Do
          If doc.Range(Start:=l_pos, End:=l_pos + 1).Font.Bold _
              = False Then Exit Do
         ->Start-Position erweitern
          l_Start_anf = l_pos
          l_pos = l_pos - 1
        Loop
        
       ->fetter Bereich
        With doc.Range(Start:=l_Start_anf, End:=l_Start_end)
         ->fette Formatierung entfernen
          .Font.Bold = False
         ->Ende-Tag einfügen
          .InsertAfter c_TAG_ENDE
          doc.Range(Start:=l_Start_end, _
                    End:=l_Start_end + Len(c_TAG_ENDE)).Font.Underline _
                    = wdUnderlineNone
         ->Anfangs-Tag einfügen
          .InsertBefore c_TAG_ANFANG
          doc.Range(Start:=l_Start_anf, _
                    End:=l_Start_anf + Len(c_TAG_ANFANG)).Font.Underline _
                    = wdUnderlineNone
        End With
        
       ->Suchbereichsende vor letztes Anfangs-Tag setzen
        l_PosEnd = l_Start_anf - 1 - Len(c_TAG_ANFANG)
      
      Loop While l_PosEnd > 0
      Set doc = Nothing
    
    End Function
    '***************************************************
    Private Function UnterstrichenenTextInHtmlTags_u_Wandeln()
    ' im gesamten Text des aktiven Documents werden
    ' Unterstreichungen (wdUnderlineSingle) in
    ' Tags <u>...</u> eingefaßt und die Unterstreichung
    ' entfernt.
    
      Const c_TAG_ANFANG = <u>
      Const c_TAG_ENDE = </u>
      
      Dim doc As Document
      Dim l_Start_anf As Long, l_Start_end As Long
      Dim l_PosEnd As Long, l_pos As Long
    
      Set doc = ActiveDocument
      
     ->Suchbereichsende setzen
      l_PosEnd = doc.Content.End
      
      Do
       ->Unterstreichung suchen, vom Ende rückwärts
        Selection.Start = doc.Content.Start
        Selection.End = l_PosEnd
        With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = True
          .Forward = False
          .Wrap = wdFindStop
          .Text = ^?
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchCase = False
          .Font.Underline = wdUnderlineSingle
          If .Execute() = False Then Exit Do->nichts gefunden ?
        End With
        
       ->Position merken
        l_Start_anf = Selection.Start
        l_Start_end = Selection.End
        
       ->Zeichen davor auch unterstrichen ?
        l_pos = l_Start_anf - 1
        Do
          If l_pos < 0 Then Exit Do
          If doc.Range(Start:=l_pos, End:=l_pos + 1).Font.Underline <> _
            wdUnderlineSingle Then Exit Do
         ->Start-Position erweitern
          l_Start_anf = l_pos
          l_pos = l_pos - 1
        Loop
        
       ->unterstrichener Bereich
        With doc.Range(Start:=l_Start_anf, End:=l_Start_end)
         ->Unterstreichung entfernen
          .Font.Underline = wdUnderlineNone
         ->Ende-Tag einfügen
          .InsertAfter c_TAG_ENDE
          doc.Range(Start:=l_Start_end, _
                    End:=l_Start_end + Len(c_TAG_ENDE)).Font.Bold = False
         ->Ende-Tag einfügen
          .InsertBefore c_TAG_ANFANG
          doc.Range(Start:=l_Start_anf, _
                    End:=l_Start_anf + Len(c_TAG_ANFANG)).Font.Bold = False
    
        End With
        
       ->Suchbereichsende vor letztes Anfangs-Tag setzen
        l_PosEnd = l_Start_anf - 1 - Len(c_TAG_ANFANG)
      
      Loop While l_PosEnd > 0
      Set doc = Nothing
    
    End Function
     
  9. Super DANKE!!!
     
Die Seite wird geladen...

Makro in Word zum Suchen und Ersetzten? - Ähnliche Themen

Forum Datum
Word 2013 VBA: Makro aus einer anderen Datei aufrufen Microsoft Office Suite 16. Juni 2014
Makro zum drucken der ersten Seite von Stck. 200 Word2007 Doc in einem Verz. Windows XP Forum 9. Aug. 2012
Schriftfarbe per Makro in Word 2003 suchen Microsoft Office Suite 28. Nov. 2011
Word Makro kann nicht aufgezeichnet werden Windows XP Forum 12. Apr. 2010
WORD: Makros deaktiviert?? Microsoft Office Suite 16. Apr. 2009