Hallo Experte,
können Sie mir helfen folgendes Problem zu lösen?
Ich habe Änderungen in vielen Texten durchzuführen, wobei die Funktion „Suchen und Ersetzen“ nicht genügt.
Ich stelle mir das so vor, dass ich manuell die interessierenden Passagen farblich markiere und dann ein Makro dafür sorgt, dass die markierten Passagen am Ende des Textes (jede Fundstelle in einem Absatz) erscheinen oder in eine neue Datei ausgegeben werden.
Können Sie mir da helfen?
Vielen Dank
Marx
Hallo hier ein Code. Der nimmt aber keine Rücksicht auf mehrere Markierte Worte in einer Zeile (einem Absatz), sondern gibt jedes Wort aus.
Sub Marker\_Feststellen1()
Dim CheckWord As String
Dim Seite As Double
Dim Zeile As Double
Dim Zeichen As Double
' am Ende des Textes einen Marker setzen
Selection.EndKey Unit:=wdStory
Selection.InsertAfter "MyEndOfStory" + vbCr
' Anfügen der Listen-Überschrift
Selection.EndKey Unit:=wdStory
Selection.TypeText Text:="Seite" & vbTab & "Zeile" & vbTab & "Zeichen" & vbCr
Selection.TypeParagraph
' Formatieren der Tabulatoren
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=2, Extend:=wdExtend
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(1.5) \_
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(3.5) \_
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
' Beginn der Suche
Selection.HomeKey Unit:=wdStory
' Suchen bis Marker
Do Until CheckWord = "MyEndOfStory"
' alte Auswahl aufheben
Selection.Collapse Direction:=wdCollapseEnd
'nächstes Wort ermitteln
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
CheckWord = Selection
'Prüfen ob Auswahl ohne "Textmarker"
If Selection.Range.HighlightColorIndex wdNoHighlight Then
'Textmarker vorhanden =\> Position ermitteln
Seite = Selection.Information(wdActiveEndPageNumber)
Zeile = Selection.Information(wdFirstCharacterLineNumber)
Zeichen = Selection.Information(wdFirstCharacterColumnNumber)
'am Ende des doc die Position eintragen
Selection.EndKey Unit:=wdStory
Selection.InsertAfter CStr(Seite) + vbTab + CStr(Zeile) + \_
vbTab + CStr(Zeichen) + vbCr
' zurück zu letzten geprüften Wort und eins weiter
Selection.GoTo What:=wdGoToPage, Count:=Seite
Selection.MoveDown Unit:=wdLine, Count:=Zeile - 1
Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=Zeichen + Len(CheckWord)
End If
Loop
End Sub
eigentlich ein kompletter Progranmmierauftrag, der 50 Euronen kosten müsste 
)
Hallo Amtsschimmel,
vielen Dank für die wertvolle Hilfe.
Das Makro funktioniert einwandfrei und hilft mir, mein Problem zu lösen.
Marx
Denk bitte daran, den Urheber „Amtsschimmel von wer-weiss-was.de“ im Code zu zitieren, wenn Du andere Nutzer damit arbeiten lässt oder es auf einem PC außerhalb Deiner Häuslichkeit (z…B. beim Arbeitgeber) aufspielst.
Zum Beispiel so
' Urheber des Makros ist Amtsschimmel von wer-weiss-was.de (c) 2012
Vermeidet auch Peinlichkeiten, wenn man (vom Arbeitgeber) zum Code befragt wird, schnell mal was anderes programmieren soll,…
Sorry für meine späte Antwort.
Leider habe ich derzeit keinen Zugriff auf eine Microsoft Office Version mehr. Daher kann ich keine Unterstützung mehr bieten.