Word VBA 対象の文字列を移動させる方法カットandペースト 2行下の文字列を検索位置へ移動する処理

要約・概要

ブログ記事では、WordのVBAマクロを使って特定の文字列を移動させる方法について説明
具体的な例として、金額を検索して内容を移動するケースを実行
移動前の形式と移動後の形式を示す例

youtu.be
Word VBA 対象の文字列を移動させる方法カットandペーストにチャレンジしてみたマクロのデバッグ動画 - YouTube
目次
00:00 1.質問内容
01:45 実行結果
05:29 VBAコードの説明を開始する 2.Selection Findで検索してみた
07:37 3.検索結果の2行下を対象の文字列に Selection Move
15:24 4.該当範囲をCut 次の位置へPaste
20:48 5.おわりの挨拶

1.質問内容

Wordのマクロの作り方について質問です。

文字を移動するマクロの作り方があったら教えてほしいです。
例
移動前が
1000円
「商品」
■対象
移動後
1000円 ■対象
「商品」
この形にしたいです。

実行結果:
https://www.youtube.com/watch?v=LpnFIy-7ofY&t=105

テスト文章:

1200円
焼き鳥皮5本タレ
内容:皮タレ5本
2500円
焼き鳥盛り合わせ
内容:盛り合わせ25本

2.Selection.Findで検索してみた
05:29
https://www.youtube.com/watch?v=LpnFIy-7ofY&t=329

まず、
Selection.Find
で、検索してみた。

Option Explicit

Sub TEST20240505_01文字列の検索()
    
    Dim str検索文字列 As String
    str検索文字列 = InputBox("検索文字列を入力", "", "1000円")
 
    ActiveDocument.Range(0, 0).Select  '先頭にカーソル移動
    With Selection.Find  '検索処理
        .Execute FindText:=str検索文字列
        If .Found = True Then
           MsgBox "検索成功"
        Else
            MsgBox "検索失敗"
        End If
    End With
 
End Sub

3.検索結果の2行下を対象の文字列にしてみた
07:37
https://www.youtube.com/watch?v=LpnFIy-7ofY&t=457

検索結果から、
Selection.MoveDown Count:=2 '2段落下にカーソル移動
で、カーソルを移動後、

選択範囲を
Selection.MoveStart wdParagraph, -1
Selection.MoveEnd wdParagraph, 1
Selection.MoveEnd wdWord, -1 '改行含めたくない時は一文字戻す、小細工
で
選択してみた

Sub TEST20240505_02検索後に2行下を選択したい()
    
    Dim str検索文字列 As String
    Dim rng見つけた場所 As Range
    
    ' 検索文字列を入力
    str検索文字列 = InputBox("金額を入力してください", "", "1000円")
    
    ActiveDocument.Range(0, 0).Select  '先頭にカーソル移動
    With Selection.Find  '検索処理
        .Text = str検索文字列   '条件のセット
        .Execute   '検索実行
        If .Found Then  '結果の判断
            ' 検索結果が見つかった場合
            Set rng見つけた場所 = Selection.Range  '後で使いたいので保存
            
            Selection.MoveDown Count:=2  '2段落下にカーソル移動
            ' 選択範囲を段落に拡張※上と合わせて、もっと良い方法がありそうだけど
            Selection.MoveStart wdParagraph, -1
            Selection.MoveEnd wdParagraph, 1
            Selection.MoveEnd wdWord, -1   '改行含めたくない時は一文字戻す、小細工
            
        Else
            MsgBox "該当する金額が見つかりませんでした。"
        End If
    End With
    
End Sub

4.該当範囲をカットして、検索結果の次へペースト・貼り付けしてみた
15:24
https://www.youtube.com/watch?v=LpnFIy-7ofY&t=924

単純に、
Selection.Cut
で、選択範囲をカットして、

覚えておいた、検索結果へ飛び、

'↑カットした範囲を挿入する、カットandペースト的な感じ
rng見つけた場所.Select '覚えていた検索結果の位置(に戻す再選択)
Selection.InsertAfter " " 'スペース1つ後ろに入れる
Selection.EndKey Unit:=wdLine, Extend:=wdMove 'カーソルを末に移動
Selection.Paste '貼り付ける(カットした文字を貼り付ける)

ソースコード全体:

'検索後に2行下をカットして検索位置の後ろに貼付
Sub TEST20240505_03検索後にカットAndペースト()
    
    Dim str検索文字列 As String
    Dim rng見つけた場所 As Range
    
    ' 検索文字列を入力
    str検索文字列 = InputBox("金額を入力してください", "", "1000円")
    
    ActiveDocument.Range(0, 0).Select  '先頭にカーソル移動
    With Selection.Find  '検索処理
        .Text = str検索文字列   '条件のセット
        .Execute   '検索実行
        If .Found Then  '結果の判断
            ' 検索結果が見つかった場合
            Set rng見つけた場所 = Selection.Range  '後で使いたいので保存
            
            Selection.MoveDown Count:=2  '2段落下にカーソル移動
            ' 選択範囲を段落に拡張※上と合わせて、もっと良い方法がありそうだけど
            Selection.MoveStart wdParagraph, -1
            Selection.MoveEnd wdParagraph, 1
            Selection.MoveEnd wdCharacter, -1   '改行含めたくない時は一文字戻す、小細工
            
            '↑の選択範囲をカットする
            Selection.Cut
            
            '↑カットした範囲を挿入する、カットandペースト的な感じ
            rng見つけた場所.Select  '覚えていた検索結果の位置(に戻す再選択)
            Selection.InsertAfter " "  'スペース1つ後ろに入れる
            Selection.EndKey Unit:=wdLine, Extend:=wdMove 'カーソルを末に移動
            Selection.Paste  '貼り付ける(カットした文字を貼り付ける)
            
        Else
            MsgBox "該当する金額が見つかりませんでした。"
        End If
    End With
    
End Sub