书签部分位置的Word到Excel数据传输(交叉引用)

Question

我正在尝试获取我的书签在Word文档(一个冗长的法律文档模板)中的编号位置(没有上下文的段落编号)和。目前，我正在使用以下代码将已添加书签的文本值从Word文档中提取到Excel工作簿中，该工作簿是为了从其他来源获取其他数据而构建的，但我还不知道如何操作代码来获取书签的段落编号(我也到处搜索这个段落编号，我是VBA新手。我知道的足够危险，但还不够有用，哈哈。请帮帮我！

Sub SectionLocationImportTESTING()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim BookmarkText As String

Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0

If wdApp Is Nothing Then
    MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
    Exit Sub
End If

Set xlWb = ThisWorkbook
Set xlWs = ActiveWorkbook.Sheets("Data Input")
intDocCount = wdApp.Documents.Count

If intDocCount > 1 Then
    MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
    "Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
    Set wdApp = Nothing
    Exit Sub
End If

With wdApp
    Set wdDoc = wdApp.ActiveDocument
    wdDoc.Activate
    
'This is very abbreviated, I have about 300 bookmarks that transfer

If wdDoc.Bookmarks.Exists("Section_Rent") = True Then
    BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
xlWs.Cells(202, 22) = ("Section_Rent")
xlWs.Cells(202, 23) = BookmarkText
End If

End With

    ActiveWorkbook.RefreshAll
    ActiveSheet.PivotTables("Data_Input_Table").PivotFields("Trimmed Data"). _
    PivotFilters.Add2 Type:=xlCaptionIsGreaterThan, Value1:="0"
    

    Columns("D:D").EntireColumn.AutoFit
    Range("A1").Select

MsgBox "Transfer is complete."

End Sub

Answer 1

我不认为有一种直接的方法可以做到这一点。

您可以这样做，例如：

Sub Tester()
    Debug.Print ParagraphNumber(Selection.Range)
End Sub


Function ParagraphNumber(rng As Range)
    ParagraphNumber = rng.Document.Range(0, rng.End).Paragraphs.Count
End Function

...but它还将计算“空”段落。

如果你有很多书签，你可以考虑在你的Excel表格中列出名字，然后遍历这个范围来运行文本提取。如果您将所有这些名称硬编码到您的VBA中，这将很难维护。

例如。

'...
Dim c As Range, bm As String, rngBM As Word.Range

'...
'...

Set wdDoc = wdApp.ActiveDocument
wdDoc.Activate
'range with your bookmark names
Set rngBM = ThisWorkbook.Sheets("Bookmarks").Range("A2:A300")

For Each c In rngBM.Cells
    bm = c.Value 'bookmark name
    If wdDoc.Bookmarks.Exists(bm) Then
        Set rngBM = wdDoc.Bookmarks(bm).Range
        'for demo purposes just putting info next to the bookmark name...
        c.Offset(0, 1).Value = rngBM.Text
        c.Offset(0, 2).Value = ParagraphNumber(rngBM)
    End If
Next c

Answer 2

有两种方法可以获取段落编号，具体取决于您想要的内容：

选项1

这将获得您在段落本身中看到的自动编号的确切字符串：

下面的段落将使您获得1.

1. 这是一个测试段落。

If wdDoc.Bookmarks.Exists("Section_Rent") Then
    Dim BookmarkText As String
    BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
                    
    xlWs.Cells(202, 22) = "Section_Rent"
    xlWs.Cells(202, 23) = BookmarkText
            
    Dim BookmarkParaNum As String
    BookmarkParaNum = wdDoc.Bookmarks("Section_Rent").Range.ListFormat.ListString
    
    xlWs.Cells(202, 24) = BookmarkParaNum
End If

选项2如果您插入对段落的交叉引用，则此选项将获取您看到的字符串：

对于选项1中的同一段落，使用下面的代码只会得到1，这与将其作为交叉引用插入会得到的结果相同。

wdDoc.Paragraphs.Last.Range.InsertParagraphAfter 'A temporary paragraph for inserting field later

Dim fieldRng As Range
Set fieldRng = wdDoc.Paragraphs.Last.Range.Duplicate

If wdDoc.Bookmarks.Exists("Section_Rent") Then
    Dim BookmarkText As String
    BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
                            
    xlWs.Cells(202, 22) = "Section_Rent"
    xlWs.Cells(202, 23) = BookmarkText
                            
    fieldRng.InsertCrossReference ReferenceType:="Bookmark", ReferenceKind:=wdNumberNoContext, ReferenceItem:="Section_Term", InsertAsHyperlink:=True, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
    Dim tempField As Field
    Set tempField = fieldRng.Fields(1)
    
    Dim BookmarkParaNum As String
    BookmarkParaNum = tempField.Result
       
    xlWs.Cells(202, 24) = BookmarkParaNum
    
    tempField.Delete
End If

fieldRng.Delete 'Delete the temporary paragraph