如何通过vba在word中按页面和行添加书签

Question

我有来自书签的列表（表格）的代码包含名称书签，没有行，没有页面。 如何通过名称，页面号和此列表（表格）中的“否”行来反向添加书签。

代码：

Sub ListBkMrks2()
Application.ScreenUpdating = False
Dim oBkMrk As Bookmark, rng As Range, StrTxt As String, StrStory As String, wdDocIn As Document, wdDocOut As Document, Dest
Dest = MsgBox(Prompt:="Output to New Document? (Y/N)", Buttons:=vbYesNoCancel, Title:="Destination Selection")
If Dest = vbCancel Then Exit Sub
Set wdDocIn = ActiveDocument
If Dest = vbYes Then Set wdDocOut = Documents.Add
If Dest = vbNo Then Set wdDocOut = wdDocIn
With wdDocIn
  If .Bookmarks.Count > 0 Then
    StrTxt = vbCr & "Bookmark" & vbTab & "Page" & vbTab & "Line" & vbTab & "Story" & Chr(160) & "Range" & vbTab & "Contents"
    For Each oBkMrk In .Bookmarks
      StrTxt = StrTxt & vbCrLf & oBkMrk.Name & vbTab
      StrTxt = StrTxt & oBkMrk.Range.Characters.First.Information(wdActiveEndAdjustedPageNumber)
      StrTxt = StrTxt & vbTab & oBkMrk.Range.Information(wdFirstCharacterLineNumber)
      Select Case oBkMrk.StoryType
        Case 1: StrStory = "Main text"
        Case 2: StrStory = "Footnotes"
        Case 3: StrStory = "Endnotes"
        Case 4: StrStory = "Comments"
        Case 5: StrStory = "Text frame"
        Case 6: StrStory = "Even pages header"
        Case 7: StrStory = "Primary header"
        Case 8: StrStory = "Even pages footer"
        Case 9: StrStory = "Primary footer"
        Case 10: StrStory = "First page header"
        Case 11: StrStory = "First page footer"
        Case 12: StrStory = "Footnote separator"
        Case 13: StrStory = "Footnote continuation separator"
        Case 14: StrStory = "Footnote continuation notice"
        Case 15: StrStory = "Endnote separator"
        Case 16: StrStory = "Endnote continuation separator"
        Case 17: StrStory = "Endnote continuation notice"
        Case Else: StrStory = "Unknown"
      End Select
      StrTxt = StrTxt & vbTab & StrStory & vbTab & oBkMrk.Range.Text
    Next oBkMrk
  Else
    MsgBox "There are no bookmarks in this document", vbExclamation
    GoTo Done
  End If
End With
With wdDocOut
  Set rng = .Range.Characters.Last
  With rng
    .Text = StrTxt
    .Start = .Start + 1
    .ConvertToTable Separator:=vbTab
    With .Tables(1)
      .AutoFitBehavior wdAutoFitContent
      .Columns.Borders.Enable = True
      .Rows.Borders.Enable = True
      .Rows.First.Range.Font.Bold = True
    End With
  End With
End With
Done:
Set rng = Nothing: Set wdDocIn = Nothing: Set wdDocOut = Nothing
Application.ScreenUpdating = True
End Sub