vba - 找到所有标题 1 的文本并将其放入一个数组中

Question

我正在使用 VBA 宏来呈现 Word 文档中的所有“标题 1”样式文本。
它工作正常，但花费大量时间取决于 word doc 的内容。

我正在循环每个段落以检查“标题 1”样式并将文本呈现为数组。

我想知道是否有另一种方法可以简单地找到“标题 1”样式并将文本存储在数组中，这将大大减少执行时间。

在我的宏程序下方，我将不胜感激任何关于上述问题的专家意见。

Sub ImportWordHeadings()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim sHeader(50) As String
Dim Head1counter As Integer
Dim arrcount As Long
Dim mHeading As String

On Error Resume Next
wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file


 p = 1
  RetCount = 0
  parg = wdDoc.Paragraphs.Count

For Head1counter = 1 To parg

   If wdDoc.Paragraphs(Head1counter).Range.Style = "Heading 1" Then

        sHeader(p) = wdDoc.Paragraphs(Head1counter).Range.Text
        p = p + 1
        Else
        p = p
   End If
Next Head1counter

For arrcount = RetCount + 1 To UBound(sHeader)

  If sHeader(arrcount) <> "" Then
        Debug.Print sHeader(arrcount)
        RetCount = arrcount
Exit For
  Else
        RetCount = RetCount
  End If
Next arrcount

Set wdDoc = Nothing

End Sub

Answer 1

您可以使用 Find method搜索所有标题，与我所做的非常相似 over here on Code Review .

Set doc = ActiveDocument
Set currentRange = doc.Range 'start with the whole doc as the current range

With currentRange.Find
    .Forward = True             'move forward only
    .Style = wdStyleHeading1    'the type of style to find
    .Execute                    'update currentRange to the first found instance

    dim p as long 
    p = 0
    Do While .Found

        sHeader(p) = currentRange.Text

        ' update currentRange to next found instance
        .Execute
        p = p + 1
    Loop
End With