三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
※フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく？ほそぼそと暮らしてます。
Ken3三流君の連絡先:
[google formsで連絡する]
上記の問い合わせフォームに質問・感想など気軽に書き込んでください。

よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

トップ > VBA > バグ付きなので参考程度に Excel VBA アクティブシート内の表をPowerPointへコピペ(転記)する 複数の表を探す #デバッグ #バグ

バグ付きなので参考程度に Excel VBA アクティブシート内の表をPowerPointへコピペ(転記)する 複数の表を探す #デバッグ #バグ

VBA Excel

www.youtube.com

1.Range("B2:D5")など固定エリアをパワーポイントに貼り付けてみる
https://www.youtube.com/watch?v=iMavOYyH2ac

2.シート内の表を探す
https://youtu.be/iMavOYyH2ac?t=329

3.とりあえず、一つ表をエクセルからパワーポイントへコピー・貼り付け
https://youtu.be/iMavOYyH2ac?t=729

4.シート内の複数表を探す
https://youtu.be/iMavOYyH2ac?t=1064

5.複数の表をパワーポイントへ
https://youtu.be/iMavOYyH2ac?t=1598

1.Range("B2:D5")など固定エリアをパワーポイントに貼り付けてみる

Option Explicit

'Excelの表 テストでRange("B2:D5")などをPowerPointのスライドに貼り付ける
Sub Excelから貼り付けテスト001()

    Dim oApp As Object
    Dim n As Integer
    
    'PowerPoint の 起動、インターフェース用のオブジェクトを作る
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True '可視にする
    
    '新規プレゼンのファイル作成 新規の空ファイル作成
    oApp.Presentations.Add WithWindow:=msoTrue
    
    'スライドの追加
    'レイアウトの種類
    'Layout:=ppLayoutText  2
    'Layout:=ppLayoutTitleOnly  11
    'Layout:=ppLayoutTwoColumnText  3
    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 = "Excel 

Range.Copyから単純に貼り付けてみる"
    '↑一番目のオブジェクトがタイトルと決めつける悪いコードですが・・

    'Excel Rangeで単純にコピーする
    Range("B2:D5").Copy     '.Copyでクリックボードへ
    
    'PowerPointに単純貼り付け
    oApp.ActiveWindow.View.Paste  '.Pasteで貼り付け
    
    '↑で貼り付けたアクティブなオブジェクトに対して操作するのは芸がないけど
    oApp.ActiveWindow.Selection.ShapeRange.Left = 0  'left=0で左寄せする
    'oApp.ActiveWindow.Selection.ShapeRange.Width = 640  '幅 widthで指定できます
    '↑せっかくコピーしたんだから、幅は指定しなくてもいいかな？
    
End Sub

2.シート内の表を探す

固定エリアのコピペ転送なんて、使えないので ぉぃぉぃ
シート内の表を探してコピーしてみます。

Excel VBA 範囲 などをキーワードに探すと、
便利なメソッドなどがみつかるので、組み合わせてテストしてみます。

Option Explicit

'シート内の表を探すには？
'シート内の表を探してみます

Sub test20210223_excel_シート内の表を探す001()

'セル範囲の取得 セル範囲の取得
' http://officetanaka.net/excel/vba/cell/cell10.htm
'より
'＞ワークシートで使用されているセル範囲
'＞ワークシート.UsedRange

    Dim objALL範囲 As Range  '全ての入力エリア

    Set objALL範囲 = ActiveSheet.UsedRange
    Debug.Print "ALL範囲.Address=" & objALL範囲.Address
    Debug.Print "ALL範囲.Rows.Count=" & objALL範囲.Rows.Count
    
'↑で、全体の範囲がわかるので

'最終行・最終列の取得方法（End,CurrentRegion,SpecialCells,UsedRange）｜VBA技術解説
' https://excel-ubara.com/excelvba4/EXCEL222.html
'より
'＞最終行 = ActiveSheet.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row

'↑今回は、最終行ではないけど、.Find("*" で入力文字を探すアイデアをいただく
'objALL範囲.Rows.Count で行数がわかるなら、

    objALL範囲.Rows("1:" & objALL範囲.Rows.Count).Find("*").Select
    '↑.Row("1:999").Find("*").select で見つかったセルを選択する
    
'↑表の一部セルを.Active(Select)できたので、
'次はその表を選択します。 そんな時に便利な

'セル範囲の取得 セル範囲の取得
' http://officetanaka.net/excel/vba/cell/cell10.htm
'より※コードの頭で紹介したURLですが
'＞ひとかたまりのセル範囲
'＞任意のセル.CurrentRegion

    Dim obj表 As Range   '表のオブジェクト Range範囲を格納する
    
    'Fandで探したセルがアクティブになっているので
    Set obj表 = ActiveCell.CurrentRegion
    '↑.CurrentRegionで、ひとかたまりのセル範囲を表とする

    Debug.Print "obj表.Address=" & obj表.Address

End Sub

3.とりあえず、一つ表をエクセルからパワーポイントへコピー・貼り付け

転記範囲をプログラムで探して※可変にして
パワーポイントへ転記してみたいと思います。

'---------------------
Sub test20210223_excel_シート内の表をパワポへ001()

    Dim objALL範囲 As Range  '全ての入力エリア

    Set objALL範囲 = ActiveSheet.UsedRange
    Debug.Print "ALL範囲.Address=" & objALL範囲.Address
    Debug.Print "ALL範囲.Rows.Count=" & objALL範囲.Rows.Count
    
'↑で、全体の範囲がわかるので
'objALL範囲.Rows.Count で行数がわかるなら、

    objALL範囲.Rows("1:" & objALL範囲.Rows.Count).Find("*").Select
    '↑.Row("1:行まで").Find("*").select で見つかったセルを選択する
    
'↑表の一部セルを.Active(Select)できたので、
'次はその表を選択します。 そんな時に便利な

    Dim obj表 As Range   '表のオブジェクト Range範囲を格納する
    
    'Fandで探したセルがアクティブになっているので
    Set obj表 = ActiveCell.CurrentRegion
    '↑.CurrentRegionで、ひとかたまりのセル範囲を表とする
    Debug.Print "obj表.Address=" & obj表.Address

'ここから、パワーポイントへ表をコピーする
    obj表.Copy   '単純に Range.Copy です Dim obj表 As Rangeなので

    'Sub Excelから貼り付けテスト001()少し前のテストそのまま
    Dim oApp As Object
    Dim n As Integer
    
    'PowerPoint の 起動、インターフェース用のオブジェクトを作る
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True '可視にする
    
    '新規プレゼンのファイル作成 新規の空ファイル作成
    oApp.Presentations.Add WithWindow:=msoTrue
    
    'スライドの追加
    'レイアウトの種類
    'Layout:=ppLayoutText  2
    'Layout:=ppLayoutTitleOnly  11
    'Layout:=ppLayoutTwoColumnText  3
    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 = "Excel 

Range.Copyから単純に貼り付けてみる"
    '↑一番目のオブジェクトがタイトルと決めつける悪いコードですが・・

    'PowerPointに単純貼り付け
    oApp.ActiveWindow.View.Paste  '.Pasteで貼り付け
    
    '↑で貼り付けたアクティブなオブジェクトに対して操作するのは芸がないけど
    oApp.ActiveWindow.Selection.ShapeRange.Left = 0  'left=0で左寄せする
    'oApp.ActiveWindow.Selection.ShapeRange.Width = 640  '幅 widthで指定できます
    '↑せっかくコピーしたんだから、幅は指定しなくてもいいかな？

End Sub

'↑↑↑↑表だけのExcelなんてないだろ？タイトルが一行目に書かれていたら？
'そんなバグを紹介しつつ

4.シート内の複数表を探す

シート内に複数の表が存在する。
一つの表を一つのスライドとしてコピペしたいので、
個別の表、範囲の取り出しを探ってみます。

下記のコード、バグ付きなので参考程度に
バグ内容: https://youtu.be/iMavOYyH2ac?t=1358

Option Explicit

'シート内の複数の表を探す
'テストでシート内の表を探し、範囲をDebug.printしてみます

Sub test20210223_excel_シート内の表を複数探す002()

    Dim objALL範囲 As Range  '全ての入力エリア
    Dim obj表 As Range   '表のオブジェクト Range範囲を格納する
    Dim objFIND As Range '検索結果
    Dim n As Integer     '表の数
    
    Dim n検索先頭行 As Integer  '.Findで探し始める行を管理する
    
    Set objALL範囲 = ActiveSheet.UsedRange '※セルの使用範囲を取得する
    
    Debug.Print "ALL範囲.Address=" & objALL範囲.Address
    Debug.Print "ALL範囲.Rows.Count=" & objALL範囲.Rows.Count
    
    '一つ目の表を探す
    n = 0
    n検索先頭行 = 1  '初回、始めは1行目から探す

'objALL範囲.Rows.Count で行数がわかるので検索先頭行が越えるまでループ
    Do While n検索先頭行 < objALL範囲.Rows.Count
    
        Set objFIND = objALL範囲.Rows(n検索先頭行 & ":" & objALL範囲.Rows.Count).Find("*")
        If objFIND Is Nothing Then Exit Do '見つからなかったらループを抜ける
        objFIND.Select
        
        '↑.Row("1:999").Find("*").select で見つかったセルを選択する
        'Fandで探したセルがアクティブになっているので
        Set obj表 = ActiveCell.CurrentRegion
        '↑.CurrentRegionで、ひとかたまりのセル範囲を表とする
        
        '↑2列x2行以上の範囲を表と判断する
        If obj表.Rows.Count >= 2 And obj表.Columns.Count >= 2 Then
            n = n + 1 '表の数
            Debug.Print ""
            Debug.Print n & "番目の表"
            Debug.Print "obj表.Address=" & obj表.Address
        
        End If
    
    
        '次の表を探すために 選択した表の次の行を調べる
        n検索先頭行 = obj表.Cells(obj表.Rows.Count, 1).Row + 1
        Debug.Print "n検索先頭行=" & n検索先頭行
    Loop

End Sub


5.複数の表をパワーポイントへ

アクティブなシートだけですが、
複数の表をパワーポイントへコピペしてみます。

※次は、ブック内のすべてのシート
※※最終的には、開いている全てのブック すべてのシート から表を そんな処理かな。

下記のコード、バグ付きなので参考程度に
バグ内容: https://youtu.be/iMavOYyH2ac?t=1358

Option Explicit

'シート内の複数の表をパワポにコピーする
'テストでシート内の表を探し、1スライドに1つの表を転記する

Sub test20210224_excel_シート内の表複数からスライドを作成する()
    
    Dim oApp As Object

    Dim objALL範囲 As Range  '全ての入力エリア
    Dim obj表 As Range   '表のオブジェクト Range範囲を格納する
    Dim objFIND As Range '検索結果
    Dim n As Integer     '表の数
    
    Dim n検索先頭行 As Integer  '.Findで探し始める行を管理する
    
    'PowerPoint の 起動、インターフェース用のオブジェクトを作る
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True '可視にする
    oApp.Presentations.Add WithWindow:=msoTrue '新規プレゼンのファイル作成 新規の空ファイル作成
    
    'Excel側 アクティブシート内の表を探しながら転記(Copy 貼り付け)する
    Set objALL範囲 = ActiveSheet.UsedRange '※セルの使用範囲を取得する
    
    Debug.Print "ALL範囲.Address=" & objALL範囲.Address
    Debug.Print "ALL範囲.Rows.Count=" & objALL範囲.Rows.Count
    
    '一つ目の表を探す
    n = 0
    n検索先頭行 = 1  '初回、始めは1行目から探す

'objALL範囲.Rows.Count で行数がわかるので検索先頭行が越えるまでループ
    Do While n検索先頭行 < objALL範囲.Rows.Count
    
        Set objFIND = objALL範囲.Rows(n検索先頭行 & ":" & objALL範囲.Rows.Count).Find("*")
        If objFIND Is Nothing Then Exit Do '見つからなかったらループを抜ける
        objFIND.Select
        
        '↑.Row("1:999").Find("*").select で見つかったセルを選択する
        'Fandで探したセルがアクティブになっているので
        Set obj表 = ActiveCell.CurrentRegion
        '↑.CurrentRegionで、ひとかたまりのセル範囲を表とする
        
        '↑2列x2行以上の範囲を表と判断する
        If obj表.Rows.Count >= 2 And obj表.Columns.Count >= 2 Then
            n = n + 1 '表の数
            Debug.Print ""
            Debug.Print n & "番目の表"
            Debug.Print "obj表.Address=" & obj表.Address
            'スライドの追加 'レイアウトの種類
            'Layout:=ppLayoutText  2
            'Layout:=ppLayoutTitleOnly  11
            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  'Excel側 表の範囲をコピーする
            DoEvents
            
            'PowerPointに単純貼り付け
            oApp.ActiveWindow.View.Paste  '.Pasteで貼り付け
            DoEvents
            
            '↑で貼り付けたアクティブなオブジェクトに対して操作するのは芸がないけど
            oApp.ActiveWindow.Selection.ShapeRange.Left = 0  'left=0で左寄せする
            DoEvents
        
        End If
    
        '次の表を探すために 選択した表の次の行を調べる
        n検索先頭行 = obj表.Cells(obj表.Rows.Count, 1).Row + 1
        Debug.Print "n検索先頭行=" & n検索先頭行
    Loop

End Sub

ランダムな占い

再生リスト:[占い 今日のラッキーカラー]をショート動画

Ken3 ホームページ 目次

分類:HPを大きく分けると４つの柱(分類)です。

  1. [VBA・マクロ プログラミング]の解説
    当店の人気はVBA系のCreateObject("XXXXXX.application")で他のアプリケーションを操作するサンプルが人気です
  2. [プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
    三流君を踏み台にする
  3. [古いクラシック ASP(Active Server Pages)]の解説。
  4. [元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い？の仕事で失敗。
主に上記４つの分類でＨＰ作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。


[連絡先はココのフォームから]←連絡先の入力フォームです、気軽に書いてください
本当に三流なんです（笑）:たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り・迷宮入りが多かったりします)