Find all Heading 1 Text and Put it into an Array

Question

I am using a VBA Macro to render all the "Heading 1" style text from a word document. It is working fine but taking huge time depends on the content of word doc.

I am looping each paragraph to check for "Heading 1" style and render the Text into an array.

I wonder if there is an alternative approach to simply find "Heading 1" style and store the text in array which would greatly reduce the execution time.

Below my Macro program and I would appreciate any expert thoughts regarding the above mentioned.

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

RubberDuck RubberDuck · Accepted Answer · 2014-12-31T15:18:54

You can use the Find method to search for all of the headings, very similar to what I did 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

Find all Heading 1 Text and Put it into an Array

1 Answers