先の[Excel VBA]WORD文書の赤字の頁番号を列挙するでは、赤字以外の属性（抹消線など）があるテキストをヒットしなかったので、改訂版です。
今回はWORDの「高度な検索」の「書式」で「赤字」だけ設定する方法を使います。
と云っても、赤文字頁番号検索()を少し変えたダケです。（笑
Public Sub 赤文字頁番号検索()
On Error GoTo err1
'初期化
Dim wordApp As Word.Application
Set wordApp = CreateObject("Word.Application")
Dim 赤字の開始行 As Long
赤字の開始行 = ActiveSheet.Range("タイトル行").row + 1
Dim 赤字の列 As Long
赤字の列 = ActiveSheet.Range("タイトル行").Find("赤字").Column
Dim 頁番号の列 As Long
On Error Resume Next
Err.Clear
頁番号の列 = ActiveSheet.Range("タイトル行").Find("赤字頁番号").Column
If Err.Number <> 0 Then
頁番号の列 = ActiveSheet.Range("タイトル行").Find("頁番号").Column
End If
'検索対象のWORD文書を開く
Dim wordFname As String
wordFname = 検索対象のWORD文書名を調べる
Dim wordDoc As Word.document
Set wordDoc = 検索対象のWORD文書を開く(wordApp, wordFname)
If TypeName(wordDoc) <> "Nothing" Then
Dim row As Long
row = 赤字の開始行
wordDoc.ActiveWindow.Selection.Start = 0
wordDoc.ActiveWindow.Selection.End = 0
Do While (高度な赤字検索(wordDoc))
Dim 赤字 As String
赤字 = wordDoc.ActiveWindow.Selection.text
赤字 = Replace(赤字, vbCr, "")
赤字 = Replace(赤字, vbLf, "")
赤字 = Trim(赤字)
If 赤字 <> "" Then
wordDoc.ActiveWindow.Selection.Copy
ActiveSheet.Cells(row, 赤字の列).Select
ActiveSheet.Paste
Dim pasteRows As Integer
pasteRows = Selection.Count
Dim st, ed
st = wordDoc.ActiveWindow.Selection.Start
ed = wordDoc.ActiveWindow.Selection.End
Dim 開始頁番号 As Integer
wordDoc.ActiveWindow.Selection.Start = st
wordDoc.ActiveWindow.Selection.End = st
開始頁番号 = wordDoc.ActiveWindow.Selection.Information(wdActiveEndAdjustedPageNumber)
Dim 終了頁番号 As Integer
wordDoc.ActiveWindow.Selection.Start = ed
wordDoc.ActiveWindow.Selection.End = ed
終了頁番号 = wordDoc.ActiveWindow.Selection.Information(wdActiveEndAdjustedPageNumber)
'右セルに頁番号を書き込む
Dim 頁番号説明文 As String
If 開始頁番号 <> 終了頁番号 Then
ActiveSheet.Cells(row, 頁番号の列).Value = 開始頁番号 & "～" & 終了頁番号 & "頁"
Else
ActiveSheet.Cells(row, 頁番号の列).Value = 開始頁番号 & "頁"
End If
row = row + pasteRows
End If
Loop
End If
exit1:
Call MSWORDをそのまま閉じる(wordApp)
Exit Sub
err1:
MsgBox Err.Description
GoTo exit1
End Sub後は、高度な赤字検索()を追加するだけです。
中身はWORDで「高度な検索」の「書式」で「赤字」だけ設定した時のマクロ記録内容を少し調整したものです。
Private Function 高度な赤字検索(wordDoc As Word.document) As Boolean
With wordDoc.ActiveWindow.Selection.Find
'書式関連を初期化
.ClearFormatting
.Font.Color = wdColorRed
'文字関連を初期化
.text = ""
.Replacement.text = ""
.Forward = True
.Wrap = wdFindStop '文書の終わりで中断
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
'検索
.Execute
'結果を取得
高度な赤字検索 = .Found
End With
End Function検索対象のWORD文書名を調べると検索対象のWORD文書を開くとMSWORDをそのまま閉じるは前の記事のままです。
Font.ColorとFont.ColorIndexのいづれを使うのか良いのかは悩ましいです。
後、デバッグ中は起動したMS-WORDをタスクマネージャから終了していましたが、上記のwordAppを外部変数にして、マクロ画面から終了させた方が便利そう。
Dim wordApp As Word.Application
・・・
Set wordApp = CreateObject("Word.Application")
・・・
public sub マクロ実行中に起動したMSWORDを強制終了
Call MSWORDをそのまま閉じる(wordApp)
End Sub