【Word VBA】蛍光ペンのある段落を丸ごと抽出するWordマクロ

先日紹介した「Word文書中の蛍光ペンのテキストを抽出するマクロ 」では、本文中の蛍光ペンで着色された部分の「テキスト」を抽出しました。

テキストなので、書式情報が失われますね。

今回は、書式情報付きで抽出する方法です。さらに、蛍光ペンがついている部分だけではなく、その段落が抽出されます。

このマクロでできること

現在開かれているWord文書の本文の蛍光ペンで着色された文字列を含む段落を、新規ファイルに書出します。

そのときに、Word文書中の該当する段落の数も表示します。

蛍光ペンを付けてチェックした部分を急いで読み返すような場合や、レポートとしてまとめ直すような場合を想定しています。

マクロの解説

赤文字部分の記載で、蛍光ペンが見つかった場合に、範囲を段落にまで拡大しています。

青文字部分の記載で、段落番号を数えています。その方法は、「現在のカーソル位置の段落番号を取得するマクロ 」に記載したとおりです。

マクロ

Sub 蛍光ペンのある段落を書出すマクロ()

　Dim myRange As Range　　'Rangeオブジェクト
　Dim newDoc As Document　'新規で開いた文書
　Dim myParaNum As Integer '段落番号

　Set myRange = ActiveDocument.Range(0, 0)
　Set newDoc = Documents.Add

　With myRange.Find
　　.Text = ""
　　.Forward = True
　　.Wrap = wdFindStop
　　.Highlight = True
　End With

　'文書の最後の蛍光ペン後は、文字列が選択されて
　'いなくても蛍光ペンが検索されたと判定されることがある
　Do While myRange.Find.Execute = True And _
　　myRange.Text <> ""

　　With myRange
　　　.Expand unit:=wdParagraph
　　　.Copy
　　　.Start = 0
　　　myParaNum = .Paragraphs.count
　　　.Collapse direction:=wdCollapseEnd
　　End With

　　With newDoc.Range
　　　.SetRange Start:=.End, End:=.End
　　　.InsertAfter Text:="【段落】：" & myParaNum & vbCr
　　　.SetRange Start:=.End, End:=.End
　　　.Paste
　　　.InsertParagraphAfter
　　End With

　Loop

　Set newDoc = Nothing
　Set myRange = Nothing

End Sub

関連記事

Word文書中の蛍光ペンのテキストを抽出するマクロ

現在のカーソル位置の段落番号を取得するマクロ