特定のアウトラインレベルで段落の内容を確認します

Question

私はワード文書の段落を通過するマクロを持っています。このコードは、段落を渡し、そのアウトラインレベルを特定し、目的の段落アウトラインレベルが見つかったときにコンテンツを取得することを目的としています。この情報を使用して、ユーザーがドキュメント内のテキストを書き出す点を選択できるようにするリストボックスを作成しています。

この機能は動作していますが、速度を向上させる方法を探しています。今、私は5678パラグラフの文書を扱っており、すべての情報を処理するのに30分以上かかります。提案はありますか？私は成功をせずにアプローチしようとした

：

1 - 私はオブジェクトTableOfContentsを使用しようとしたが、しかし、私はきれいな情報を持っていると段落からアウトラインレベルを区別することができませんでした。

2 - 私は、特別な理由コマンド_docSource.GetCrossReferenceItems（wdRefTypeHeading）の使用、また無成功

でここでフォームのイメージがあり、ここGetting the headings from a Word documentからコードを適応しようとしましたと私が使用しているコード。

Sub ProcessHeaders() 
Dim j As Long 
Dim Paragraph_Number() As Variant 
Dim Paragraph_Content() As Variant 
Dim Paragraph_Mapping() As Variant 
j = 1 
With UserForm1 
If .ComboBox4.ListCount > 0 Then 
    .ComboBox4.Clear 
End If 

For i = 1 To wordDoc.Paragraphs.Count 
If wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel1 _ 
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel2 _ 
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel3 _ 
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel4 Then 
If wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString <> "" Then 
    ReDim Preserve Paragraph_Number(j) 
    ReDim Preserve Paragraph_Content(j) 
    Paragraph_Content(j) = wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString & " " & Trim(Left(wordDoc.Paragraphs.Item(i).Range.Text, (Len(wordDoc.Paragraphs.Item(i).Range.Text) - 1))) 
    Paragraph_Number(j) = i 
    j = j + 1 
End If 
End If 
Next i 

    ReDim Preserve Paragraph_Mapping(1 To UBound(Paragraph_Content), 1) 
    For i = 1 To UBound(Paragraph_Number) 
    Paragraph_Mapping(i, 0) = Paragraph_Content(i) 
    Paragraph_Mapping(i, 1) = Paragraph_Number(i) 

    Next i 

.ComboBox4.List = Paragraph_Mapping 
End With 
End Sub 

編集1 - 私は以下のコードと実行の8分〜32分の時間を短縮することが実現。さらに改善するための提案はありますか？事前に感謝

Sub ProcessHeaders() 
Dim j As Long 
Dim thisOutlineLevel As WdOutlineLevel 
Dim thisHeader As String 
Dim thisList As String 
Dim ParagraphCount As Long 

Dim Paragraph_Number_Base() As Variant 
Dim Paragraph_Content_Base() As Variant 
Dim Paragraph_ListItem_Base() As Variant 

Dim ParagraphContent() As Variant 
Dim ParagraphNumber() As Variant 
Dim Paragraph_Mapping() As Variant 

Dim StartTime As Double 
Dim MinutesElapsed As String 



j = 1 
With UserForm1 
If .ComboBox4.ListCount > 0 Then 
    .ComboBox4.Clear 
End If 

ParagraphCount = wordDoc.Paragraphs.Count 

ReDim Paragraph_Content_Base(ParagraphCount + 1) 
ReDim Paragraph_ListItem_Base(ParagraphCount + 1) 
ReDim Paragraph_Number_Base(ParagraphCount + 1) 


StartTime = Timer 
For i = 1 To ParagraphCount 
MinutesElapsed = Format((Timer - StartTime)/86400, "hh:mm:ss") 
UserForm1.Label7.Caption = "Reading Paragraphs. " & Format(i/ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & " | Time Elapsed: " _ 
& MinutesElapsed & " Minutes" 
With wordDoc.Paragraphs.Item(i) 
    Select Case .OutlineLevel 
     Case wdOutlineLevelBodyText 
      GoTo ResumeNext 
     Case wdOutlineLevel1, wdOutlineLevel2, wdOutlineLevel3, wdOutlineLevel4 
      Paragraph_Content_Base(i) = .Range.Text 
      Paragraph_ListItem_Base(i) = .Range.ListFormat.ListString 
      Paragraph_Number_Base(i) = i 
    End Select 
End With 

ResumeNext: 
Next i 
MinutesElapsed = Format((Timer - StartTime)/86400, "hh:mm:ss") 
UserForm1.Label7.Caption = ParagraphCount & " read on " & MinutesElapsed & " Minutes. Now, identifying the Headers" 

For i = 0 To UBound(Paragraph_Content_Base) 
    If Paragraph_Content_Base(i) <> "" And Paragraph_ListItem_Base(i) <> "" Then 
     ReDim Preserve ParagraphContent(j) 
     ReDim Preserve ParagraphNumber(j) 
     ParagraphContent(j) = Trim(Paragraph_ListItem_Base(i)) & " " & Trim(Left(Paragraph_Content_Base(i), Len(Paragraph_Content_Base(i)) - 1)) 
     ParagraphNumber(j) = Paragraph_Number_Base(i) 
     j = j + 1 
    End If 
Next i 


Erase Paragraph_Content_Base 
Erase Paragraph_ListItem_Base 
Erase Paragraph_Number_Base 

    ReDim Preserve Paragraph_Mapping(1 To UBound(ParagraphContent), 1) 
    For i = 1 To UBound(ParagraphNumber) 
     Paragraph_Mapping(i, 0) = ParagraphContent(i) 
     Paragraph_Mapping(i, 1) = ParagraphNumber(i) 
    Next i 

.ComboBox4.List = Paragraph_Mapping 
MinutesElapsed = Format((Timer - StartTime)/86400, "hh:mm:ss") 
UserForm1.Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes" 
End With 

編集2 - Cindyのヘルプでは、当初32分で実行されていたコードは32秒で実行されています。ここに最終的なコードがあります。

Sub ProcessHeaders() 
    Dim rng As Word.Range 
    Dim para As Word.Paragraph 
    Dim lstFormat As Word.ListFormat 
    Dim paraNr() As Variant 
    Dim paraContent() As Variant 
    Dim counter As Long, paraIndex As Long 

    Dim Paragraph_Mapping() As Variant 
    Dim ParagraphCount As Long 
    Dim i, j As Long 

    Dim StartTime As Double 
    Dim StartRealTime As Date 
    Dim MinutesElapsed As String 

    With UserForm1 
    If .ComboBox4.ListCount > 0 Then 
     .ComboBox4.Clear 
    End If 

    counter = 1 
    paraIndex = 1 
    i = 0 
    j = 1 
    StartTime = Timer 
    StartRealTime = Now 
    Set rng = wordDoc.Content 
    ParagraphCount = rng.ListParagraphs.Count 

    For Each para In rng.ListParagraphs 
     i = i + 1 
     Set lstFormat = para.Range.ListFormat 
     MinutesElapsed = Format((Timer - StartTime)/86400, "hh:mm:ss") 
     .Label7.Caption = "Reading Paragraphs. " & Format(i/ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & _ 
     " | Start Time: " & StartRealTime & " | Time Elapsed: " & MinutesElapsed & " Minutes" 
     'CheckOutLine = rng.ListParagraphs.Item(1).OutlineLevel 
       If lstFormat.ListString <> "" And Len(lstFormat.ListString) >= 2 Then 
        ReDim Preserve paraNr(counter) 
        ReDim Preserve paraContent(counter) 
        paraContent(counter) = lstFormat.ListString & " " _ 
              & Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1))) 
        paraNr(counter) = i 
        wordDoc.Bookmarks.Add Name:="ExpContent" & i, Range:=para.Range 
        counter = counter + 1 
       End If 
     paraIndex = paraIndex + 1 
    Next 
j = 1 

    ReDim Preserve Paragraph_Mapping(1 To UBound(paraNr), 1) 
    For i = UBound(paraNr) To 1 Step -1 
     Paragraph_Mapping(j, 0) = paraContent(i) 
     Paragraph_Mapping(j, 1) = paraNr(i) 
     j = j + 1 
    Next i 
    .ComboBox4.List = Paragraph_Mapping 
    MinutesElapsed = Format((Timer - StartTime)/86400, "hh:mm:ss") 
    .Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes" 
    End With 

' 
' For counter = 1 To UBound(paraNr) 
'  Debug.Print paraNr(counter) & vbTab & paraContent(counter) 
' Next 
End Sub 

、ユーザーが段落を選択した後、ブックマークはもう一度この呼び出し

With objWord.Selection 
     BookmarkID = "ExpContent" & PositionReference 
     wordDoc.Bookmarks(BookmarkID).Select 
     .InsertParagraphBefore 
End With 

によって管理されている、私は最速のアプローチだと思うあなた

Answer 1

に感謝すべての段落ではなく、番号付きの段落だけをループすることになります。これは、ListParagraphsオブジェクトを使用して行うことができます。たとえば、次のように

Sub IdOutlineLevels() 
    Dim rng As word.Range 
    Dim para As word.Paragraph 
    Dim lstFormat As word.ListFormat 
    Dim paraNr() As Variant 
    Dim paraContent() As Variant 
    Dim counter As Long, paraIndex As Long 

    counter = 1 
    paraIndex = 1 
    Set rng = ActiveDocument.content 
    For Each para In rng.ListParagraphs 
     Set lstFormat = para.Range.ListFormat 
     Select Case lstFormat.ListLevelNumber 
      Case 1, 2, 3, 4 
       If lstFormat.ListString <> "" Then 
        ReDim Preserve paraNr(counter) 
        ReDim Preserve paraContent(counter) 
        paraContent(counter) = lstFormat.ListString & " " _ 
              & Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1))) 
        paraNr(counter) = paraIndex 
        counter = counter + 1 
        ActiveDocument.Bookmarks.Add Name:="ExpContent" & counter, Range:=para.Range 
       End If 
      Case Else 
     End Select 
     paraIndex = paraIndex + 1 
    Next 

    For counter = 1 To UBound(paraNr) 
     Debug.Print paraNr(counter) & vbTab & paraContent(counter) 
    Next 
End Sub 

よりもむしろもう一度段落を見つけるために、文書内の段落のインデックス番号に頼る私は、段落番号と同じ「カウンター」を使用して段落のそれぞれにブックマークを追加しました。これは、Word自体が相互参照に使用する手法です。