Help us understand the problem. What is going on with this article?

Excelシートの選択範囲・選択グラフをパワーポイントにサクサク貼り付け

More than 3 years have passed since last update.

エクセルのシートの内容(セル範囲・オートシェイプ・グラフ)を、
開いているパワーポイントのスライドにサクサク貼り付けるマクロ。

複数シート&複数範囲 を選択すると、
各選択範囲をループして一括で貼り付けます。

お作法完全無視の酷いコードですが共有。

※参照設定でパワーポイントオブジェクトの参照必須です。

Dim yohaku, top_yohaku, mytitle
Dim myrange, mybook, myppt
Dim Tempslide, TempI
Dim mySelections, mySRange

'選択範囲をPPTに図として貼り付け
Sub PastePPT_Pic()

    Dim PPT As New PowerPoint.Application
    If PPT.Presentations.Count >= 2 Or _
        PPT.Presentations.Count = 0 Then
        MsgBox "貼り付け先のパワーポイントを1つだけ開いて、やり直して下さい", vbCritical
        End
    End If

    '説明
    If MsgBox("【開いているPPT】の【選択中のスライド】をコピーして、" & vbCr & vbCr & _
                "【エクセルの選択範囲】を【図として】貼り付けます。" & vbCr & vbCr & vbCr & vbCr & _
                "※複数シート選択すると、一括処理できます。", vbOKCancel) = vbCancel Then End

    '設定
    yohaku = Application.InputBox("左右の余白は何ポイント?(初期設定:20)", , 20, , , , , 1)
    If yohaku = False Then End
    top_yohaku = Application.InputBox("上の余白は何ポイント?(初期設定:80)", , 80, , , , , 1)
    If top_yohaku = False Then End

    Set mybook = ActiveWorkbook

    TempI = 0

    '選択シートを後ろから順番に処理する。
    Set mysheets = ActiveWindow.SelectedSheets
    Application.ScreenUpdating = False
    For i = mysheets.Count To 1 Step -1
        mysheets(i).Select
        Set mySelections = Nothing
        Set myrange = Nothing
        one_flg = False

        If TypeName(Selection) = "Range" Then
            Set mySelections = Selection.Areas
            Set mySRange = Selection
        ElseIf TypeName(Selection) Like "Chart*" Then
            Set mySelections = Selection.Parent.Parent.ShapeRange
        Else
            Set mySelections = Selection.ShapeRange
        End If

        For j = mySelections.Count To 1 Step -1
            Set myrange = mySelections(j)
            If mySelections.Count = 1 Then
                mytitle = ActiveSheet.Name
            Else
                mytitle = ActiveSheet.Name & "_" & j
            End If
            Call PastePPT_Pic_Loop(PPT)
        Next
    Next

    Tempslide.Select

    'コピー元を選択しなおす
    If TypeName(mySelections(1)) = "Range" Then
        mySRange.Select
    ElseIf TypeName(mySelections(1)) Like "Chart*" Then
        mySelections(1).Select
    Else
        For Each myselect In mySelections
            myselect.Select False
        Next
    End If
    Application.ScreenUpdating = True
End Sub

'現在のスライド選択するテスト
Sub test_getslide()
    Dim PPT As New PowerPoint.Application
    Set piyobook = ActiveWorkbook
    For i = 1 To 100
        Set Tempslide = Nothing
        piyobook.Activate
        PPT.Activate
        'テンプレスライド
        Do While TypeName(Tempslide) = "Empty" Or TypeName(Tempslide) = "Nothing"
            Sleep 100
            Set Tempslide = PPT.Windows(1).Selection.SlideRange
            Debug.Print i, Tempslide.Name
        Loop
    Next
End Sub

Private Sub PastePPT_Pic_Loop(PPT)
    Set myppt = PPT.Presentations(1)

    '貼り付け=======================================
    myrange.Select
    myrange.Copy

    PPT.Activate
    '選択中のスライドをテンプレスライドとする。
    TempI = PPT.Windows(1).Selection.SlideRange.SlideIndex
    Set Tempslide = PPT.ActivePresentation.Slides(TempI)

    '貼り付けスライド挿入
    Tempslide.Duplicate.MoveTo topos:=TempI + 1
    Set myslide = PPT.ActivePresentation.Slides(TempI + 1)
    swidth = myslide.CustomLayout.Width
    sheight = myslide.CustomLayout.Height - 5
    myslide.Select

    With myslide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
        .LockAspectRatio = True
        .Top = top_yohaku
        If (sheight - top_yohaku) < .Height Then .Height = (sheight - top_yohaku)
        If (swidth - (yohaku * 2)) < .Width Then
            .Width = swidth - (yohaku * 2)
            .Left = yohaku
        Else
            .Left = (swidth - .Width) / 2
        End If
    End With
    myslide.Shapes.title.TextFrame.TextRange.Text = mytitle

    Application.CutCopyMode = False
End Sub
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした