三流君 ken3のmemo置き場

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

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

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

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を大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



Googleを使用して検索する

読者の声:三流君の説明・解説じゃ よくわからなかったから、Googleを使って、自分で検索します。
三流君:残念です。あっ、下記にGoogleの検索窓を設置しました。
いろいろ指定して試してみてください。

Google
探す言葉:気になる単語や,オブジェクト(Document),プロパティ(.Busy)やメソッド(.Navigate)などを入れて検索してみてください。


言語を指定:見つからない時は指定無しで探す

サイト指定:人気QAサイト や 一次情報MS本家を指定する
一次情報・二次情報まとめから探る
QAサイトの質問から探る
検索実行: ←オプション確認後に検索ボタンを押してください

期間指定:情報の鮮度も大切?
検索実行: ←オプション確認後に検索ボタンを押してください


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