Word文書で表キャプションを上から下に、またはその逆に移動するにはどうすればよいですか？

Author: Xiaoyang Last Modified: 2025-08-06

Word文書内に、各表の下に挿入されたキャプションを持つ複数の表がある場合、状況によってはこれらのキャプションを表の下から上に移動したい場合があります。この作業をできるだけ早く一括で処理するにはどうすればよいでしょうか？

VBAコードを使用してWordで表キャプションを下から上に、またはその逆に移動する

VBAコードを使用してWordで表キャプションを下から上に、またはその逆に移動する

すべての表キャプションを表の下から上に移動するために、次のVBAコードが役立ちます。以下の手順を行ってください：

1. ALT + F11キーを押したままにし、Microsoft Visual Basic for Applicationsウィンドウを開きます。

2. 「挿入」>「モジュール」をクリックし、次のマクロをモジュールウィンドウに貼り付けます。

Word文書で表キャプションを下から上に移動する

Sub ReLabelDownToUpTables()
    Dim I As Long
    Dim xRngPre As Range
    Dim xRngNext As Range
    Application.ScreenUpdating = False
    With ActiveDocument
        For I = .Tables.Count To 1 Step -1
            With .Tables(I).Range
                Set xRngPre = .Characters.First.Previous.Characters.Last
                xRngPre.Select
                Set xRngNext = .Characters.Last.Next.Paragraphs.First.Range
                xRngNext.Select
                With xRngPre
                    .InsertBefore vbCr
                    .Style = xRngNext.Style
                    .Start = .End - 1
                    .End = .Start
                End With
                If Len(xRngNext.Text) > 1 Then
                    xRngNext.End = xRngNext.End - 1
                    xRngNext.Cut
                    xRngNext.Delete
                    xRngPre.Paste
                Else
                    xRngNext.Delete
                End If
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub

3. その後、 F5キーを押してこのコードを実行すると、すべての表キャプションが表の下から上に移動され、スクリーンショットをご覧いただけます：

All table captions are moved from below to above

注: 表キャプションを表の上から下に移動するには、次のVBAコードを適用してください：

Word文書で表キャプションを上から下に移動する

Sub ReLabelUpToDownTables()
    Dim I As Long
    Dim xRngPre As Range
    Dim xRngNext As Range
    Application.ScreenUpdating = False
    With ActiveDocument
        For I = .Tables.Count To 1 Step -1
            With .Tables(I).Range
                Set xRngNext = .Characters.First.Previous.Paragraphs.First.Range
                xRngNext.Select
                Set xRngPre = .Characters.Last.Next
                xRngPre.End = xRngPre.End - 1
                xRngPre.Select
                With xRngPre
                    .InsertBefore vbCr
                    .Style = xRngNext.Style
                    .Start = .End - 1
                    .End = .Start
                End With
                If Len(xRngNext.Text) > 1 Then
                    xRngNext.End = xRngNext.End - 1
                    xRngNext.Cut
                    xRngNext.Delete
                    xRngPre.Paste
                Else
                    xRngNext.Delete
                End If
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub