Sub SearchOutlineLevel()  
Dim oPara As Paragraph
Dim rng As Range
Dim t_range As Range
Dim oDoc As Document
Set oDoc = ActiveDocument
oDoc.Bookmarks.ShowHidden = False
For Each oPara In oDoc.Paragraphs
  With oPara
    Set rng = .Range
    If .Range.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then
      Select Case .Range.ParagraphFormat.OutlineLevel
      Case 1 To 9
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
      End Select
    End If
  End With
Next oPara
End Sub  

Function fktCheckString(sText As String) As String  
  If IsNumeric(Left(sText, 1)) = True Then
    Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(sText, 1))) = 0
      sText = Right(sText, Len(sText) - 1)
    Loop
  End If
  ' Nichterlaubte Zeichen filtern  
  sText = Replace(sText, " ", "_")
  sText = Replace(sText, Chr(13), "")
  sText = Replace(sText, ".", "")
  sText = Replace(sText, "-", "_")
  sText = Replace(sText, "/", "_")
  sText = Replace(sText, "&", "_")
  sText = Replace(sText, "<", "_")
  sText = Replace(sText, ">", "_")
  sText = Replace(sText, Chr(34), "")
  fktCheckString = sText
End Function  

Sub HeadingsToBookmarks()  
Dim BM As Bookmark, t_rng As Range
Dim i As Integer
Dim oDoc As Document
Dim strBM As String, bfound As Boolean
Dim rng As Range
Dim aBM() As String
' Aktives Dokument  
Set oDoc = ActiveDocument
' Keine versteckten Textmarken anzeigen  
ActiveDocument.Bookmarks.ShowHidden = False
' Alle Querverweise für Überschriften  
aBM() = oDoc.GetCrossReferenceItems(wdRefTypeHeading)
For i = LBound(aBM()) To UBound(aBM())
  Set rng = oDoc.Content
  With rng.Find
    'Überschriften suchen  
    .Text = Trim(aBM(i))
    ' evtl. Überschriftennummierung entfernen  
    If IsNumeric(Left(.Text, 1)) = True Then
      Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(.Text, 1))) = 0
        .Text = Right(.Text, Len(.Text) - 1)
      Loop
    End If
    .MatchCase = True
    .MatchWholeWord = True
    .Execute
    ' Wurde ein Verweistext gefunden?  
    Do While .Found = True
      'rng.Select  
      Select Case rng.Style
      Case oDoc.Styles(wdStyleHeading1), _
        oDoc.Styles(wdStyleHeading2), _
        oDoc.Styles(wdStyleHeading3), _
        oDoc.Styles(wdStyleHeading4), _
        oDoc.Styles(wdStyleHeading5)
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
    End Select
    .Execute
    Loop
  End With
Next i
weiter:
' Überschriften, die nicht mit den Standardformatvorlagen formatiert sind  
aBM() = oDoc.GetCrossReferenceItems(wdRefTypeNumberedItem)
For i = LBound(aBM()) To UBound(aBM())
  Set rng = oDoc.Content
  With rng.Find
    .Text = Trim(aBM(i))
    ' evtl. Überschriftennummierung entfernen  
    If IsNumeric(Left(.Text, 1)) = True Then
      Do While InStr(1, "abcdefghijklmnopqrstuvwxyz", LCase(Left(.Text, 1))) = 0
        .Text = Right(.Text, Len(.Text) - 1)
      Loop
    End If
    .MatchCase = True
    .MatchWholeWord = True
    .Execute
    ' Wurde ein Verweistext gefunden?  
    Do While .Found = True
    'rng.Select  
    Select Case rng.ParagraphFormat.OutlineLevel
    Case 1 To 9
        Set t_rng = rng.Duplicate
        ' Absatzmarken in der Überschrift?  
        If InStr(1, t_rng, Chr(13)) > 0 Then
          t_rng.End = t_rng.End - Len(Chr(13))
        End If
        ' Korrekte Textmarkennamen erzeugen  
        sBM = fktCheckString(t_rng.Text)
        ' Besitzt die Überschrift schon eine Textmarke?  
        If t_rng.Bookmarks.Count > 0 Then
        ' wenn ja und abweichend vom Namen dann löschen  
          If t_rng.Bookmarks(1).Name <> sBM Or Len(t_rng.Bookmarks(1).Range) <> Len(t_rng.Text) Then
            t_rng.Bookmarks(1).Delete
            ' Textmarke neu setzen  
            oDoc.Bookmarks.add sBM, t_rng
          End If
        Else
          ' Keine Textmarke vorhanden, dann neu setzen  
          oDoc.Bookmarks.add sBM, t_rng
        End If
    End Select
    .Execute
    Loop
  End With
Next i
End Sub