エクセルのシートの内容(セル範囲・オートシェイプ・グラフ)を、
開いているパワーポイントのスライドにサクサク貼り付けるマクロ。
複数シート&複数範囲 を選択すると、
各選択範囲をループして一括で貼り付けます。
お作法完全無視の酷いコードですが共有。
※参照設定でパワーポイントオブジェクトの参照必須です。
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