https://www.relief.jp/docs/word-vba-selection-goto-table.html
-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
※ 下記設定必要
「Microsoft Word 16.0 Object Library」の参照設定
Option Explicit
Private Sub CommandButton1_Click()
'画面を更新しない
Application.ScreenUpdating = False
'確認メッセージを表示しない
Application.DisplayAlerts = False
Dim Wd As New Word.Application
Dim Doc As Word.Document
If Dir(ThisWorkbook.Path & "\" & "test2.docx") <> "" Then
Kill ThisWorkbook.Path & "\" & "test2.docx"
End If
FileCopy ThisWorkbook.Path & "\" & "test.docx", ThisWorkbook.Path & "\" & "test2.docx"
Set Doc = Wd.Documents.Open(ThisWorkbook.Path & "\" & "test2.docx")
Const Cnum As String = ".1234567890"
Dim info1 As Long
Dim info2 As Long
Dim info3 As Long
Dim i As Long
Dim i2 As Long
Dim i2_save As Long
Dim s As String
Dim s2_bf As String
Dim s2_af As String
Dim j As Long
'beforeの修正
With Doc.ActiveWindow
.Selection.Find.Text = "%"
.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
.Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext
.Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext
i2_save = 0
Do While .Selection.Find.Execute
.Selection.Range.HighlightColorIndex = wdBrightGreen
info1 = .Selection.Range.Information(wdActiveEndAdjustedPageNumber)
info2 = .Selection.Range.Information(wdStartOfRangeRowNumber)
info3 = .Selection.Range.Information(wdStartOfRangeColumnNumber)
i = .Selection.Range.Start
i2 = .Selection.Range.End
Debug.Print "(1)info1=" & info1
Debug.Print "(1)info2=" & info2
Debug.Print "(1)info3=" & info3
Debug.Print "(1)i=" & i
Debug.Print "(1)i2=" & i2
Debug.Print "(1)i2_save=" & i2_save
s = ""
s2_bf = ""
s2_af = ""
'巻き戻りによる重複判定回避
If i >= i2_save Then
If (info1 = 2 And info2 = 8 And info3 = 2) Or _
(info1 = 2 And info2 = 10 And info3 = 2) Then
j = i - 5
Do While j < i
Doc.Range(j, j + 1).HighlightColorIndex = wdYellow
s = Doc.Range(j, j + 1).Text
If InStr(Cnum, s) = 0 Then
s = ""
End If
s2_bf = s2_bf & s
j = j + 1
Loop
j = 1
Do While j <= Len(s2_bf)
Doc.Range(i - 1, i).Text = ""
j = j + 1
i = i - 1
Loop
s2_af = "99"
.Selection.InsertBefore (s2_af)
End If
End If
i2_save = i2 + WorksheetFunction.Max(-1 * Len(s2_bf) + Len(s2_af), 0)
Loop
End With
'afterの修正
With Doc.ActiveWindow
.Selection.Find.Text = "最大となる日は"
.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
.Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext
.Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext
i2_save = 0
Do While .Selection.Find.Execute
.Selection.Range.HighlightColorIndex = wdBrightGreen
info1 = .Selection.Range.Information(wdActiveEndAdjustedPageNumber)
info2 = .Selection.Range.Information(wdStartOfRangeRowNumber)
info3 = .Selection.Range.Information(wdStartOfRangeColumnNumber)
i = .Selection.Range.Start
i2 = .Selection.Range.End
Debug.Print "(2)info1=" & info1
Debug.Print "(2)info2=" & info2
Debug.Print "(2)info3=" & info3
Debug.Print "(2)i=" & i
Debug.Print "(2)i2=" & i2
Debug.Print "(2)i2_save=" & i2_save
s = ""
s2_bf = ""
s2_af = ""
'巻き戻りによる重複判定回避
If i >= i2_save Then
If (info1 = 2 And info2 = 7 And info3 = 2) Or _
(info1 = 2 And info2 = 9 And info3 = 2) Then
j = i2
Do While j < i2 + 10
Doc.Range(j, j + 1).HighlightColorIndex = wdYellow
s = Doc.Range(j, j + 1).Text
s2_bf = s2_bf & s
If InStr("日", s) > 0 Then
Exit Do
End If
j = j + 1
Loop
j = 1
Do While j <= Len(s2_bf)
Doc.Range(i2, i2 + 1).Text = ""
j = j + 1
Loop
s2_af = "11月1日"
.Selection.InsertAfter (s2_af)
End If
End If
i2_save = i2 + WorksheetFunction.Max(-1 * Len(s2_bf) + Len(s2_af), 0)
Loop
End With
Doc.Save
Doc.Close
Wd.Quit
Set Doc = Nothing
Set Wd = Nothing
MsgBox "処理完了"
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
End Sub
