Найти все заголовки 1 Текст и поместить его в массив

Question

Я использую макрос VBA для рендеринга текста текста «Заголовок 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