VBAでUsedRangeとCurrentRegionを使い、Excelシート上の全テーブルをPowerPointへ一括貼り付けする方法'

Excel VBA シート内の「全ての表」をPowerPointへ一括貼り付けする！

「エクセルのシートに表が10個もある…これを一つずつパワポに貼るだけで1日が終わってしまう…」
そんな絶望を感じている事務職やエンジニアの方へ。

今回は、Excel VBAを使って''「シート内の全ての表を自動で探し出し、PowerPointの新規スライドへ1枚ずつ貼り付ける」''という魔法のようなツール作成に挑戦しました。

この記事で解決できること

• エクセルシート上のバラバラな位置にある「複数の表」を自動検出し、コピペの手間をゼロにします。
• 指定した範囲だけでなく、シート全体をスキャンして表を特定するロジックが学べます。

処理のイメージ

作成したVBAソースコード

シート内の表を順に探し出し、PowerPointへ貼り付ける実践的なコードです。
（※一部、タイトル行の誤検知などの課題を含んだ「成長中」のコードです）

Option Explicit

'シート内の複数の表を探してPowerPointへ一括貼り付け
Sub ExcelToPowerPoint_AllTables()
    Dim oApp As Object
    Dim n As Integer
    Dim obj表 As Range
    Dim objFIND As Range
    
    '1. PowerPointの起動と新規プレゼン作成
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True
    oApp.Presentations.Add WithWindow:=msoTrue
    
    n = 0
    '2. Findメソッドでシート内のデータをスキャン
    '※UsedRange（使用範囲）からデータが入っているセルを探す
    Set objFIND = ActiveSheet.UsedRange.Find("*")
    
    Do While Not objFIND Is Nothing
        '見つかったセルの塊（表）を特定
        Set obj表 = objFIND.CurrentRegion
        
        '2列×2行以上の範囲を表とみなす
        If obj表.Rows.Count >= 2 And obj表.Columns.Count >= 2 Then
            n = n + 1
            
            'パワポに新しいスライドを追加して貼り付け
            oApp.ActiveWindow.View.GotoSlide Index:=oApp.ActivePresentation.Slides.Add(Index:=n, Layout:=2).SlideIndex
            oApp.ActiveWindow.Selection.SlideRange.Shapes(1).TextFrame.TextRange.Text = ActiveSheet.Name & ":" & n & "番目の表"
            
            obj表.Copy
            DoEvents
            oApp.ActiveWindow.View.Paste
        End If
        
        '次の表を探す（ここでは簡易的に、今の表の「次」から再検索）
        '※この部分は表の重なり等によって調整が必要です
        Set objFIND = ActiveSheet.UsedRange.FindNext(After:=obj表.Cells(obj表.Cells.Count))
        
        '無限ループ防止。次の表が見つからなければ終了
        If objFIND.Address = ActiveSheet.UsedRange.Find("*").Address Then Exit Do
    Loop
    
    MsgBox n & "個の表を転送しました！"
End Sub

手順のポイント解説

1. 「表」の範囲をどうやって決めるか？

今回の工夫は、''.Find("*")'' で何らかのデータが入っているセルを探し、そこから ''.CurrentRegion'' を使って「繋がっている表の範囲」を一気に取得している点です。これで、表の場所がズレていても柔軟に対応できます。

2. 連続貼り付けの仕組み

Do Loop文の中で、表を見つけるたびにPowerPoint側のスライド枚数をカウントアップしながら ``.Slides.Add`` しています。これにより、1表1スライドの綺麗なプレゼン資料が自動で作られます。

残された課題とAIからのアドバイス

今回のコードには、実は''「誠実なバグ」''が残っています。

• ''表の重なり問題：'' 隣接しすぎている表をうまく切り分けられない場合があります。
• ''タイトル行の誤検知：'' 表のタイトルだけが離れていると、それも一つの表と誤解してしまうことがあります。

''AIからの改善提案：''
次は、表のタイトルを自動で認識させてスライドの「タイトル」欄に自動入力させる機能を追加すると、より「実務でそのまま使える」最強ツールになりますね。

解説動画とタイムスタンプ

動画でじっくり手順を確認したい方は、以下のリンクから各工程へ飛べます。

• [00:00](https://www.youtube.com/watch?v=iMavOYyH2ac&t=0s) ：基本編。特定の固定範囲（B2:D5）をパワポに送る最小構成
• [05:29](https://www.youtube.com/watch?v=iMavOYyH2ac&t=329s) ：表の自動スキャン。UsedRangeとFindで「表の開始位置」を探す
• [12:09](https://www.youtube.com/watch?v=iMavOYyH2ac&t=729s) ：とりあえず一つ、見つけた表をパワポへコピー・貼り付け
• [17:44](https://www.youtube.com/watch?v=iMavOYyH2ac&t=1064s) ：核心部。Do Loopでシート内の「全ての表」をループ処理する
• [26:38](https://www.youtube.com/watch?v=iMavOYyH2ac&t=1598s) ：仕上げ。全ての表をスライドを分けながら一括転送！
• [30:15](https://www.youtube.com/watch?v=iMavOYyH2ac&t=1815s) ：今後の課題。全シート対応へのヒント

関連リンク

今回の詳細なデバッグ記録（ブログ）
Google検索：VBAで表をパワポに貼る方法をもっと調べる

これからも、三流プログラマーなりに「現場で役立つ泥臭い自動化」を発信していきます。
「助かった！」という方は、ぜひYouTubeのチャンネル登録もお願いします！