Find all heading 1 text and put it in an array
I am using a VBA macro to display all "Heading 1" style text from a dictionary document. It works fine, but huge time depends on the content of the doc word.
I'll loop each paragraph to check the Heading 1 style and put the text into an array.
I wonder if there is an alternative approach to simply find the "Heading 1" style and store the text in an array, which will significantly reduce the runtime.
Below is my Macro program, and I would appreciate any thoughts regarding the above.
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
+3
source to share
1 answer
You can use the Find method to find all the headers very similar to what I did here in the Code overview section .
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
+1
source to share