macroコードを短縮できるでしょうか。

質問

下記のコードで、実行できます。大部分はマクロを記憶し、同じ処理を重ねただけのものです。
目的は、ワードで選択した文字列の中から数字を削除します。
ただし、下記のような場合は削除しません。
【請求項１】、項２、ないし３、いずれか１、【００１９】、第３の、

この処理を行うために、差別化しました。
まず、数字を赤字で太字にしました。
次に、上記の、削除しては具合が悪い数字については、明朝で標準に戻すようにしてから、赤字で太字の数字を削除しました。

２０００文字を超えるので、途中大幅にカットしました。
以下は、コードです。
~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub 符号削除()
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Range.Find
.ClearFormatting
.Text = "第１"
.Replacement.Text = ""
.Replacement.Font.Color = 1
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Range.Find
.ClearFormatting
.Text = "第２"
.Replacement.Text = ""
.Replacement.Font.Color = 1
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With

Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Range.Find
.ClearFormatting
.Text = "又は２"
.Replacement.Text = ""
.Replacement.Font.Color = 1
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
↓以下、２０まで繰り返し
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Range.Find
.ClearFormatting
.Text = "乃至２０"
.Replacement.Text = ""
.Replacement.Font.Color = 1
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "１"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
↓以下、９，０まで繰り返し
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "９"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "０"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
~~同じ繰返しを短くする部分の正規表現の使い方やloopを指南していただけたら幸甚です。

回答No.1

Wendy02

こんにちは。

基本的には、私は、もうここのカテゴリでは書く意欲自体を失ってしまったのですが、気になった個々の方に関しては、ある程度まで、サポートはさせていただくことにしています。

もし、記録マクロで出来ているのでしたら、そのままお使いになればよいと思います。あえて、コードをまとめようと欲をかいても、こちらの書いたコードが、出来ない-->分からない-->そのまま　ということでは、まったく意味がありません。

>２０００文字を超えるので、途中大幅にカットしました。

ExcelでもWordでも、VBEditor 内のひとつのプロシージャとしては、一般的に、100行程度までです。
ですから、それ以上の行数では、基本的なマクロの形態を有していない可能性が強いです。その場合は、プロシージャを分散させて、Call マクロ名、とすればよいです。

質問のご要望は、同じような内容のマクロを一つにしてほしいということだと思いますが、残念ながら、ご質問の要点が良く分かりません。分からない部分は、コードを読めということだと思います。それでは、少し乱暴です。それに、本来、マクロの基礎的なものですから、それをする以前の部分が、ネックとなる可能性があるかもしれません。

>削除しては具合が悪い数字については、明朝で標準に戻すようにしてから、赤字で太字の数字を削除しました。

でも、コードを見る限りは、そうはなっていないようです。規定の太字で数字が含まれた文字を削除する、ということでしょうか。

サンプルを示しておきます。「太字」になっている、リストの文字を削除します。

削除したりする内容や仕様が変わるなら、内容を変えて、もう一つ、ループを作ればよいです。

元のコードでは、なぜ、Private ステートメントなど付けたのでしょうか、そういう部分がわかりません。
'-------------------------------------------

Sub 符号削除2()
Dim blFound As Boolean
Dim arData1 As Variant
Dim v As Variant

'一覧のリストを以下に、「,(コンマ）」で切って入れます。

Const fDATA1 As String = "第[０-９],又は[２-９],又は１[０-９],乃至２０,[０-９]"
arData1 = Split(fDATA1, ",")
blFound = True

For Each v In arData1
Do
　　With Selection.Range.Find
　　　　.ClearFormatting
　　　　.Font.Bold = True
　　　　.Text = v
　　　　.Replacement.Text = ""
　　　　.Format = True
　　　　.Wrap = wdFindContinue
　　　　.MatchCase = False
　　　　.MatchWholeWord = False
　　　　.MatchByte = False
　　　　.MatchAllWordForms = False
　　　　.MatchSoundsLike = False
　　　　.MatchFuzzy = False
　　　　.MatchWildcards = True

　　　 blFound = .Execute(Replace:=wdReplaceAll)
　　End With
Loop While blFound = True
Next v
End Sub

'----------------------------

お礼

>基本的には、私は、もうここのカテゴリでは書く意欲自体を失ってしまったのですが、気になった個々の方に関しては、ある程度まで、サポートはさせていただくことにしています。

こんにちは、Wendy02さん、ちょっとさみしいですね。

＞もし、記録マクロで出来ているのでしたら、そのままお使いになればよいと思います。あえて、コードをまとめようと欲をかいても、こちらの書いたコードが、出来ない-->分からない-->そのまま　ということでは、まったく意味がありません。

今度のマクロの狙いは、用語+符号の文書で符号を消すことです。
特許明細書は、実施形態の記載欄より上側の部分は符号を入れないことになっています。符号を入れると、裁判で争いになったときに、狭く解釈される恐れがあるからです。ですが、明細書作成中は、符号がないことには、なかなか頭の中に入りません。それで、全文を通じて符号を入れて作成します。クライアントへ送るときに、実施形態の記載欄より上側の部分は符号を全部取り除きます。権利範囲のボリュームが多いときは、符号が半端ではないほど多く入っています。消し忘れも起きることがあります。３，４年経って、出願について審査が行われ、拒絶理由通知がきたときには、自分が書いた文章でもすっかり忘れていて、権利範囲の用語に符号をつけることから、解釈し反論します。ですから、符号を消さない文書もストックしておけば、後々楽になりますが、出願用には符号を外す必要があります。それで、今度のマクロを考えました。マクロ作成は、検索置換のウインドウで部分的の操作してコードを拾って積み重ね、実行を繰り返しましたので、問題なく動きます。ですが、同じ処理を延々と書くのは、どうなのか？、と疑問に思った次第です。それに、権利範囲を３０以上書く場合もある（私は２０位までです）のでまとめられたらいいと考えていました。1つの出願が１０００頁というのも過去にありました。
Wendy02さんの示されたサンプルコードに従って、マクロ記録したコードをいじってみます。