【第2回】Word VBA：リクレーム＆要約書を自動化

　　2021/08/02の第2回の配信が完了しました。ご視聴いただきありがとうございました。

今回のポイントは、検索に関する頻出テクニック、

・更新したいときは前後で「はさみうち」：◆ﾘｸﾚｰﾑ1◆◆ｺｺﾏﾃﾞ◆

・検索するときは、If .Execute / Do While .Execute　を使え

・検索用ウィンドウと、編集用ウィンドウを作って、オリジナルのウィンドウと合わせてトリプルウィンドウ体制でプログラムを組め！

の３つでした！ワイルドカードもより複雑なものが登場しています。次回もよろしくおねがいします。

Sub 自動リクレームと要約書()

'まずは変数を定義する！
Dim originalW As Window, searchW As Window, editW As Window

'現在のアクティブウィンドウを「originalW」と命名
Set originalW = ActiveDocument.ActiveWindow

'現在のカーソル位置を記憶しておく
cursorNum = Selection.Start

'サブプロシージャ「検索用ページの準備」の呼び出し
Call 検索用ページの準備

'現在のアクティブウィンドウを「searchW」と命名
Set searchW = ActiveDocument.ActiveWindow


'searchWで請求項１を探して、編集
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = True
   
   '【請求項２または【書類名】を探す
   .Text = "【請求項１】*【[請書][求類][項名][２】]"
   If .Execute Then
       Selection.Start = Selection.Start + 6
       Selection.End = Selection.End - 5
       Selection.Copy
       
       '次の検索のために、選択を解除しておく
       Selection.Start = Selection.End
       
       '新規の白紙ページを開いてペースト
       Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
       Selection.Paste
       
       '現在のアクティブウィンドウを「editW」と命名
       Set editW = ActiveDocument.ActiveWindow
   Else
       'searchWを閉じる
       searchW.Close DoNotSave
       Selection.Start = cursorNum
       Selection.End = cursorNum
       MsgBox ("請求項がありません。原稿をご確認ください！")
       End '処理を中断する
   End If
End With

'editWで、編集
With Selection.Find
       
   Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
   .MatchFuzzy = False
   .MatchWildcards = True
   'インデントとしての改行を削除
   .Text = "^13[　]{1,}"
   .Replacement.Text = "^13"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting

   '改行や改ページを削除
   .Text = "[^12^13]"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
       
End With
'請求項１のリクレーム用記載をカットして、オリジナル原稿に貼り付ける。
Selection.WholeStory
Selection.End = Selection.End - 1 '最後の改行を消すために１戻る（ノウハウ）
Selection.Cut
   
   
'ウィンドウの切替
originalW.Activate

'originalWで、編集
With Selection.Find
       
   Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
   .MatchFuzzy = False
   .MatchWildcards = True
   
'識別子がある限り繰り返す｡
   
   .Text = "◆ﾘｸﾚｰﾑ1◆*◆ｺｺﾏﾃﾞ◆"
   Do While .Execute
   Selection.Start = Selection.Start + 8
   Selection.End = Selection.End - 7
   Selection.Paste
   Loop
   .ClearFormatting
   .Replacement.ClearFormatting
End With


'ウィンドウの切替
searchW.Activate

'searchWで請求項２以下を探して、編集
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = True
   .Text = "【請求項２】*【書類名】"
   If .Execute Then
       Selection.Start = Selection.Start + 6
       Selection.End = Selection.End - 5
       Selection.Copy
       
   Else
       'searchW等を閉じる
       searchW.Close DoNotSave
       editW.Close DoNotSave
       Selection.Start = cursorNum
       Selection.End = cursorNum
       MsgBox ("請求項２以下がありません。請求項１だけリクレームしました。")
       End '処理を中断する
   End If
End With


'ウィンドウの切替
editW.Activate
Selection.Paste

'editWで、編集
With Selection.Find
       
   Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
   .MatchFuzzy = False
   .MatchWildcards = True
   'インデントを削除
   .Text = "^13[　]{1,}"
   .Replacement.Text = "^13"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting

   '改行や改ページを削除
   .Text = "[^12^13]"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
   
   '【請求項】を段落番号に置換する
   .Text = "【請求項[０-９]{1,}】"
   .Replacement.Text = "^13　【００００】^13　"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
   
   '引用を消して「上記の」と置換する
   .Text = "請求項*記載の"
   .Replacement.Text = "上記の"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
       
End With
   '請求項２以下のリクレーム用記載をカットして、オリジナル原稿に貼り付ける。
   Selection.WholeStory
   Selection.End = Selection.End - 1 '最後の改行を消すために１戻る（ノウハウ）
   Selection.Cut
   
   'ウィンドウの切替
   originalW.Activate
   
   
'originalWで、編集
With Selection.Find
       
   Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
   .MatchFuzzy = False
   .MatchWildcards = True
   
'識別子がある限り繰り返す｡
   .Text = "◆ﾘｸﾚｰﾑ2~◆*◆ｺｺﾏﾃﾞ◆"
   Do While .Execute
   Selection.Start = Selection.Start + 9
   Selection.End = Selection.End - 7
   Selection.Paste
   Loop
   .ClearFormatting
   .Replacement.ClearFormatting
   .Text = ""
   .Replacement.Text = ""
End With

'searchW等を閉じる
searchW.Close DoNotSave
editW.Close DoNotSave

'元のカーソル位置に復帰
Selection.Start = cursorNum
Selection.End = cursorNum

MsgBox ("最新のクレームにリクレームしました！")

End Sub

Sub 検索用ページの準備()

'本文を全選択（ヘッダとフッタは無し！）
Selection.EndKey Unit:=wdStory, Extend:=wdMove 'カーソルをエンドに飛ばす
Selection.Start = 0

'全選択（ヘッダとフッタを含む）
'Selection.WholeStory

'コピー
Selection.Copy

'新規の白紙ページを開く
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0

'ペースト
Selection.Paste

'コメント全削除
Selection.Comments.Add Range:=Selection.Range, _
Text:="a"
ActiveDocument.DeleteAllComments

'変更履歴を反映
ActiveDocument.Revisions.AcceptAll

Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす

End Sub