【Word VBA】箇条書きをバラしてPowerPointへ一括転記！コピペ地獄からの解放

こんにちは、Ken3です。

今回は、YouTubeのコメントや知恵袋でよく見かける「Wordの大量の箇条書きを、PowerPointのスライドやテキストボックスに一括でバラして貼り付けたい」という切実な悩み（コピペ地獄）を、Word VBAを使って解決してみました。

「30個も50個も手作業でコピペしてられないよ！」という方は、ぜひ今回のマクロを試してみてください。

www.youtube.com

視聴者様からの相談：箇条書きを一括転記したい

きっかけは、このようなご質問でした。

Q. パワーポイントに詳しい方へ Wordに、箇条書きで書いた文が30から50個ほどあります。（1文20～30文字程度）これらの文を、スライドに別々に載せたいのですが、何か手っ取り早い方法はありますでしょうか。ワードから１文ずつコピーペーストでスライドに載せるのも大変なので...

これを手作業でやると、Ctrl+C → Ctrl+V → スライド追加 → Ctrl+V... の繰り返しで日が暮れてしまいます。そこで、「Wordで範囲選択した行（段落）を、PowerPointへ自動転送するマクロ」を作成しました。

ポイント：Selection.Paragraphs で段落を回す

今回の肝は、Word VBAの Selection オブジェクトです。

Selection.Paragraphs.Count：選択範囲の段落数を取得
Selection.Paragraphs(n).Range.Text：n番目の段落の文字列を取得

これを使って、Word側で選択したテキストを1行ずつ取り出し、PowerPoint側へ渡します。

【重要】ハマりポイント：段落記号は取れない！

マクロを作る前に、一つ重要な注意点があります。 Range.Text で文字列を取得する場合、Wordの自動機能でついている「段落番号（1. 2.）」や「箇条書き記号（・）」は取得できません。

本文のテキストデータのみが取得される仕様です。この挙動を確認するためのテストコードがこちらです。

'Word VBA: 選択範囲のテキストをイミディエイトウィンドウに出力するテスト
Sub test_DebugPrint()
    Dim n As Integer
    
    '全ての段落をテスト表示
    For n = 1 To Selection.Paragraphs.Count
        '段落番号や・は取得されず、文字だけが表示されます
        Debug.Print n & ":" & Selection.Paragraphs(n).Range.Text
    Next n
End Sub

実践コード1：箇条書きを「個別のテキストボックス」にする

まずは、Wordで選択した複数行を、PowerPointの1枚のスライド上に「個別のテキストボックス」としてバラバラに配置するマクロです。（起動中のPowerPointの、一番後ろのスライドに追加します）

'Word VBA
'選択範囲を段落ごとにPowerPointのテキストボックスとして新規作成する
Sub 起動済みPowerPointに001テキストボックス追加()

    '起動済みのパワポを捕まえる
    Dim ppApp As Object
    Set ppApp = Nothing
    
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    If ppApp Is Nothing Then
        MsgBox "PowerPointを起動してから実行してください", vbExclamation
        Exit Sub
    End If

    '最後尾に新規スライドを追加 (レイアウト:白紙=12)
    Dim p As Integer
    Dim ppSld As Object
    p = ppApp.ActivePresentation.Slides.Count + 1
    Set ppSld = ppApp.ActivePresentation.Slides.Add(p, 12) 'ppLayoutBlank
    ppSld.Select

    'テキストボックスの配置設定
    Dim ppShape As Object
    Dim set_X As Double, set_Y As Double, set_FontSize As Double

    set_X = 50      '左位置
    set_Y = 50      '上位置（ここから順に下へずらす）
    set_FontSize = 36

    Dim n As Integer
    Dim strWORD As String
    
    '選択されている段落数分ループ
    For n = 1 To Selection.Paragraphs.Count
        strWORD = Selection.Paragraphs(n).Range.Text 'テキスト取得
        
        'テキストボックスを追加 (Orientation, Left, Top, Width, Height)
        Set ppShape = ppSld.Shapes.AddTextbox(1, set_X, set_Y, 800, 50)
         
        With ppShape.TextFrame.TextRange
            .Text = strWORD
            .Font.Size = set_FontSize
        End With
         
        '次のボックスと重ならないようにY座標をずらす
        set_Y = set_Y + ppShape.Height + 10 
    Next n

    MsgBox "転記完了しました", vbInformation
    
End Sub

実践コード2：箇条書きを「別々のスライドタイトル」にする

次は、「30行あるから、30枚のスライドにしてタイトルに入れたい」という場合のコードです。 1行につき1枚、スライドが増殖していきます。

'Word VBA
'選択範囲を段落ごとに「新規スライドのタイトル」へ転記する
Sub 起動済みPowerPointに002タイトルを追加()

    '起動済みのパワポを捕まえる
    Dim ppApp As Object
    Set ppApp = Nothing
    
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    If ppApp Is Nothing Then
        MsgBox "PowerPointを起動してから実行してください", vbExclamation
        Exit Sub
    End If

    Dim p As Integer
    Dim ppSld As Object
    Dim n As Integer
    Dim strWORD As String
    
    '選択されている段落数分ループ
    For n = 1 To Selection.Paragraphs.Count
    
        'Wordのテキストを取得
        strWORD = Selection.Paragraphs(n).Range.Text
        
        '最後尾に新規スライドを追加
        p = ppApp.ActivePresentation.Slides.Count + 1
        
        'ppLayoutTitle(1) や ppLayoutText(2) など適宜変更してください
        '今回は ppLayoutText(2) = タイトルとコンテンツ で作成
        Set ppSld = ppApp.ActivePresentation.Slides.Add(p, 2)
        ppSld.Select
      
        'スライドのタイトルエリアへ文字列をセット
        ppSld.Shapes.Title.TextFrame.TextRange.Text = strWORD
       
    Next n

    MsgBox "スライド生成完了", vbInformation
    
End Sub

未解決の問題と今後の課題

動画内でも少し触れましたが、いくつか積み残しの課題があります。

段落番号（1. 2. etc）が消えてしまう
- Range.Text では本文しか取れないため、番号が必要な場合は手動で振り直すか、別のプロパティ（ListFormat.ListStringなど）を使う必要があります。
部分選択の挙動
- 行の途中（例えば「あいうえお」の「うえ」だけ）を選択していても、Paragraphs オブジェクトは「その行全体」を取得します。「選択した文字だけ」を転記したい場合は処理を変える必要があります。
スライドレイアウトの指定
- 今回は ppLayoutText (2) などを使いましたが、既存のテンプレートデザインに合わせる場合は、適切なLayoutインデックスを指定する必要があります。

まとめ

WordからPowerPointへの転記は、GetObject でアプリを捕まえて、Wordの Selection.Paragraphs でループさせれば自動化できます。単純作業で消耗している方は、ぜひ一度試してみてください。

編集後記：AIからのアドバイス（積み残し課題への提案）

Ken3さん、今回のブログ記事では動画内のコードを整理して掲載しました。動画内で「段落番号が取れない」とおっしゃっていましたが、ブログ読者の満足度をさらに上げるための「次回の改善ネタ」を提案させてください。

課題：箇条書きの番号（1. 2. A. B.）も取得したい場合

Ken3さんのご指摘通り、Range.Textでは番号が取れません。しかし、Range.ListFormat.ListString というプロパティを使うと、Wordで自動表示されている「1.」や「・」という記号部分を文字列として取得できます。

修正案のヒント:

Dim strNumber As String
'段落記号（1. や ・）を取得する
strNumber = Selection.Paragraphs(n).Range.ListFormat.ListString

'本文と結合する
strWORD = strNumber & " " & Selection.Paragraphs(n).Range.Text