Textmarken anspringen .....

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub QuerverweisAufTextmarkeEinfügen() ' Wandelt das Wort hinter einem * in einen Querverweis auf die Textmarke gleichen Namens On Error Resume Next 'Setzt Makro fort, wenn Wort nach Stern keiner Textmarke entspricht Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting ' * Suchen Do While .Execute(FindText:="*", Format:=False) = True 'Wort nach dem Stern markieren Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'Wort durch Querverweis auf Textmarke ersetzen, wenn Wort = Text Selection.InsertCrossReference ReferenceType:="Textmarke", ReferenceKind:= _ wdContentText, ReferenceItem:=Selection.Text, InsertAsHyperlink:=True, _ IncludePosition:=False 'Schleife beenden, wenn Selection am Textende If Selection.Range.End = ActiveDocument.Range.End Then Exit Do Selection.MoveRight Unit:=wdCharacter, Count:=1 Loop End With End Sub

Sub QuerverweisAufTextmarkeEinfügen() ' Wandelt das Wort hinter einem * in einen Querverweis auf die Textmarke gleichen Namens On Error Resume Next 'Setzt Makro fort, wenn Wort nach Stern keiner Textmarke entspricht ActiveDocument.Save Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting ' * Suchen Zaehler = 0 Application.ScreenUpdating = False Do While .Execute(FindText:="*", Format:=False) = True 'Wort nach dem Stern markieren Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'Wort durch Querverweis auf Textmarke ersetzen, wenn Wort = Text Selection.InsertCrossReference ReferenceType:="Textmarke", ReferenceKind:= _ wdContentText, ReferenceItem:=Selection.Text, InsertAsHyperlink:=True, _ IncludePosition:=False 'Schleife beenden, wenn Selection am Textende If Selection.Range.End = ActiveDocument.Range.End Then Exit Do Selection.MoveRight Unit:=wdCharacter, Count:=1 Zaehler = Zaehler + 1 If Zaehler = 100 Then ActiveDocument.Save Zaehler = 0 End If Loop Application.ScreenUpdating = True End With End Sub

Sub QuerverweisAufTextmarkeEinfügen() ' Wandelt das Wort hinter einem * in einen Querverweis auf die Textmarke gleichen Namens On Error GoTo Weiter1 'Setzt Makro fort, wenn Wort nach Stern keiner Textmarke entspricht ActiveDocument.Save Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting ' * Suchen Zaehler = 0 Application.ScreenUpdating = False Do While .Execute(FindText:="*", Format:=False) = True 'Wort nach dem Stern markieren Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'Wort durch Querverweis auf Textmarke ersetzen, wenn Wort = Text Selection.InsertCrossReference ReferenceType:="Textmarke", ReferenceKind:= _ wdContentText, ReferenceItem:=Selection.Text, InsertAsHyperlink:=True, _ IncludePosition:=False 'Querverweis formatieren (blau, unterstrichen) Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Font.ColorIndex = wdBlue Selection.Font.Underline = wdUnderlineSingle Weiter1: 'Schleife beenden, wenn Selection am Textende If Selection.Range.End = ActiveDocument.Range.End Then Exit Do Selection.MoveRight Unit:=wdCharacter, Count:=1 Zaehler = Zaehler + 1 If Zaehler = 100 Then ActiveDocument.Save Zaehler = 0 End If Loop Application.ScreenUpdating = True End With End Sub

Hallo Uwe,
scheinbar funktioniert das Abfangen eines Fehlers nach den zusätzlichen Zeilen nicht mehr korrekt.
Ich hatte in meiner Testdatei nur einen Fehler eingebaut, da klappt es noch. Treten nacheinander mehrere Fehler bei der Zuweisung des Links auf eine Textmarke auf, dann bricht das Makro ab.
Ich habs jetzt so abgeändert, dass immer das Wort hinter einem Stern mit den Namen aller vorhandenen Textmarken verglichen wird und bei Übereinstimmumg erfolgt die Umwandlung in einen Link und die Formatierung. So war zwar auch meine ursprüngliche Idee gewesen, aber nachdem es mit der einfachen Fehlerroutine funktionierte hab ich es dann doch nicht gemacht.
Schon erstaunlich wie sich eine kleine Prozedur mit ein paar Zusatzwünschen verändern muss.
Gruß
Franz


Sub QuerverweisAufTextmarkeEinfügen()
' Wandelt das Wort hinter einem * in einen Querverweis auf die Textmarke gleichen Namens
Dim Zaehler As Long, Textmarke As Bookmark
ActiveDocument.Save
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
' * Suchen
Zaehler = 0
Application.ScreenUpdating = False
Do While .Execute(FindText:="*", Format:=False) = True
'Wort nach dem Stern markieren
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
If Selection.Type <> wdSelectionColumn Then 'nicht nur ein Stern steht in Zelle
'Wort durch Querverweis auf Textmarke ersetzen, wenn Wort = Text
For Each Textmarke In ActiveDocument.Bookmarks
If Textmarke.Name = Selection.Text Then
Selection.InsertCrossReference ReferenceType:="Textmarke", ReferenceKind:= _
wdContentText, ReferenceItem:=Selection.Text, InsertAsHyperlink:=True, _
IncludePosition:=False
'Querverweis formatieren (blau, unterstrichen)
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.ColorIndex = wdBlue
Selection.Font.Underline = wdUnderlineSingle
Exit For
End If
Next Textmarke
End If
'Schleife beenden, wenn Selection am Textende
If Selection.Range.End = ActiveDocument.Range.End Then Exit Do
Selection.MoveRight Unit:=wdCharacter, Count:=1
Zaehler = Zaehler + 1
If Zaehler = 100 Then
ActiveDocument.Save
Zaehler = 0
End If
Loop
Application.ScreenUpdating = True
End With
End Sub

Sub HyperlinkAufTextmarkeEinfügen() ' Wandelt das Wort hinter einem * in einen Hyperlink auf die Textmarke gleichen Namens um Dim Zaehler As Long, Textmarke As Bookmark, strText As String ActiveDocument.Save Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting ' * Suchen Zaehler = 0 Application.ScreenUpdating = False Do While .Execute(FindText:="*", Format:=False) = True 'Wort nach dem Stern markieren Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend If Selection.Type <> wdSelectionColumn Then 'nicht nur ein Stern steht in Zelle 'Wort durch Hyperlink auf Textmarke ersetzen, wenn Wort = Text strText = Trim(Selection.Text) 'Leerzeichen am Anfang/Ende entfernen If Right(Selection.Text, 1) = " " Then Blank = " " 'Leerzeichen Else Blank = ""'kein Leerzeichen End If For Each Textmarke In ActiveDocument.Bookmarks If Textmarke.Name = strText Then ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _ SubAddress:=strText, ScreenTip:="", TextToDisplay:=strText Selection.TypeText Text:=Blank 'Leerzeichen hinter Wort ggf. wieder einfügen Exit For End If Next Textmarke End If 'Schleife beenden, wenn Selection am Textende If Selection.Range.End = ActiveDocument.Range.End Then Exit Do Selection.MoveRight Unit:=wdCharacter, Count:=1 Zaehler = Zaehler + 1 If Zaehler = 100 Then ActiveDocument.Save Zaehler = 0 End If Loop Application.ScreenUpdating = True End With End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread