Microsoft Word 2010での検索と置換

Question

改善しようとしているMicrosoft Word用のVBAマクロがあります。

マクロは、典型的には、マクロの目的は、Word文書内の単語/語句を強調したり、最初のための脚注を挿入することである約500セクション

に分割されているの周りに50,000語のWord文書で使用され各セクションのその語句の出現。 （Excelファイル190の語句程度）

がExcelファイル内の文書と単語の数のセクションの数をカウント

：

次のようにマクロによって行わ操作であります

その後、Word文書の最初のセクションで、最初の単語または句がExcelファイルから最初に出現することが検出されます。

それはそれは、そのセクション

にその単語またはフレーズのすべてのインスタンスの色を変更し、その単語またはフレーズ（Excelファイル内の別の列からなるテキスト）

ための脚注を挿入

この操作は、文書の最後まで次のセクションに対してこの操作を繰り返します。

次に、最初のセクションに戻り、Excelリストの次の単語の処理を繰り返します。

問題は、検索と置換操作が完全に完了するまでにかかることです。

Excelリストは降順でソートされ、最大のフレーズまたは単語が最初に表示されます。

これは、フレーズの一部が小さな語句のコンパウンドであるために行います。大きなフレーズが最初に配置され、変更されるため、フレーズの小さい方の要素が検索と置換によって誤ってピックアップされません。

文書はセクション内にあります。各セクションの最初のインスタンスに脚注があり、残りは色の変更によって強調表示されます。

検索と置換の操作は、190,000回（1セクションにつき500セクション* 190ワード* 2操作）発生します。つまり、コンピュータで実行するには数日かかります。

私はループの順序を巡って遊んでいますが、達成したい出力を維持しながらこのコードを実行するのにかかる時間をいかに短縮するかについては犠牲になっています。

私はこの操作を実行するためのよりよい方法についていくつかの助言/提案をしてもらえますか？ここで

は、私が働いているコードのコピーです：VBAでの作業時

Sub Test() 
Word.Application.ScreenUpdating = False 
Dim xlapp As Object 
Dim xlbook As Object 
Dim xlsheet As Object 
Dim xlrange1 As Object 
Dim xlrange2 As Object 
Dim myarray As Variant 
Dim Findarray As Variant 
Dim Replarray As Variant 
On Error Resume Next 
Set xlapp = GetObject(, "Excel.Application") 
If Err Then 
bstartApp = True 
Set xlapp = CreateObject("Excel.Application") 
End If 
On Error GoTo 0 
With xlapp 
Set xlbook = .Workbooks.Open("C:\Users\Documents\test.xlsx") 
Set xlsheet = xlbook.Worksheets(2) 
With xlsheet 
Set xlrange1 = .Range("A1", .Range("A1").End(4)) 
Set xlrange2 = .Range("B1", .Range("B1").End(4)) 
Findarray = xlrange1.Value 
Replarray = xlrange2.Value 
End With 
End With 
If bstartApp = True Then 
xlapp.Quit 
End If 
Set xlapp = Nothing 
Set xlbook = Nothing 
Set xlsheet = Nothing 
Set xlrange1 = Nothing 
Set xlrange2 = Nothing 
iSectCount = ActiveDocument.Sections.Count 
For i = 2 To UBound(Findarray) 
For x = 1 To iSectCount 
ActiveDocument.Sections(x).Range.Select 
Selection.Find.ClearFormatting 
Selection.Find.Font.Color = -587137025 
Selection.Find.Replacement.ClearFormatting 
With Selection.Find 
.Text = Findarray(i, 1) 
.Forward = True 
.Format = True 
.MatchWholeWord = True 
End With 
If Selection.Find.Execute Then 
ActiveDocument.Footnotes.Add Range:=Selection.Range, Text:=Replarray(i, 1) 
End If 
ActiveDocument.Sections(x).Range.Select 
Selection.Find.ClearFormatting 
Selection.Find.Font.Color = -587137025 
Selection.Find.Replacement.ClearFormatting 
Selection.Find.Replacement.Font.Color = wdColorBlue 
With Selection.Find 
.Text = Findarray(i, 1) 
.Replacement.Text = Findarray(i, 1) 
.Forward = True 
.Format = True 
.MatchWholeWord = True 
End With 
Selection.Find.Execute Replace:=wdReplaceAll 
ActiveDocument.Save 
Next x 
Next i 
End Sub  

Screenshot of the excel spreedsheet

Screenshot of Word document

Answer 1

いくつかの一般的な原則です：

1. は使用しないでくださいSelectionオブジェクトは、immのコードを遅くします。特にこのような状況では、毎回画面を再描画する必要があるため、特にそうです。 ScreenUpdatingを無効にしてもあまり効果がありません。
2. For Each ... Nextループは通常、インデックスカウンタを使用するよりも高速に実行されます。
3. すべての変数を宣言するように、モジュールの上部にOption Explicitを必ず含めてください。これはVBEで最も簡単に達成されます。オプション|変数の宣言が必要な場合は、それを追加するすべての新しいモジュールに追加します。

次のコードは、Excelで終了した後のサンプルコードを置き換えます。 500回のセクションを190回処理するのに必要な反復回数を考えると、まだ高速にはならないが、現在のコードよりも速く実行する必要があります。

Set doc = ActiveDocument 
For i = 2 To UBound(findArray) 
    For Each sec In doc.Sections 
     Set findRange = sec.Range 
     With findRange.Find 
      .ClearFormatting 
      .Replacement.ClearFormatting 
      .Text = findArray(i, 1) 
      .Forward = True 
      .Format = True 
      .MatchWholeWord = True 
     End With 
     If findRange.Find.Execute Then 
      ActiveDocument.Footnotes.Add Range:=findRange, Text:=replArray(i, 1) 
     End If 
     Set findRange = sec.Range 
     With findRange.Find 
      .Replacement.ClearFormatting 
      .Replacement.Font.Color = wdColorBlue 
      .Text = findArray(i, 1) 
      .Replacement.Text = findArray(i, 1) 
      .Forward = True 
      .Format = True 
      .MatchWholeWord = True 
     End With 
     findRange.Find.Execute Replace:=wdReplaceAll 
     doc.Save 
    Next sec 
Next i 
Application.ScreenUpdating = True