.Select 메서드를 사용하지 않고 Excel에서 PowerPoint VBA로 이미지를 붙여 넣는 방법

Question

Excel 문서의 데이터를 사용하여 Excel VBA에서 PowerPoint를 만드는 코드를 작성하고 있습니다. 이 문서에서는 IMG라는 시트가 있는데 여기에는 "그림 X"라는 일련의 이미지가 있으며 X는 현재 그림의 번호입니다. 이 그림을 복사하여 각각의 PowerPoint 슬라이드에 붙여 넣기위한 코드는 .Select 메서드를 사용합니다.이 메서드는 내가 읽은 바에 따르면 코드가 느리게 실행되며 피할 수 있어야합니다. ".Select"방법을 사용하지 않고도 엑셀 시트의 이미지를 붙여 넣을 수 있는지 알고 싶습니다.

내가 사용하고있는 코드는 다음과 같습니다

Dim pptSlide As PowerPoint.Slide 

Sheets("IMG").Select 
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select 
    Selection.Copy 

pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select 
pptSlide.Shapes(4).Width = 121 
pptSlide.Shapes(4).Height = 51 
pptSlide.Shapes(4).Left = 580 
pptSlide.Shapes(4).Top = 3 

감사 나머지 내 코드의

: "선택"오브젝트를 피하는

Dim pptApp As PowerPoint.Application 
Dim pptPres As PowerPoint.Presentation 
Dim pptSlide As PowerPoint.Slide 
Dim pptShape As PowerPoint.Shape 
Dim excelTable As Excel.Range 
Dim SlideTitle As String 
Dim SlideText As String 
Dim SlideObject As Object 
Dim pptTextbox As PowerPoint.Shape 
Dim SlideNumber As String 
Dim myPic As Object 



On Error Resume Next 
Set pptApp = New PowerPoint.Application 


Set pptPres = pptApp.Presentations.Add 
pptPres.PageSetup.SlideSize = ppSlideSizeOnScreen 
pptPres.ApplyTemplate "c:\Program Files\Microsoft Office\Templates\1033\Blank.potx" 

pptPres.PageSetup.FirstSlideNumber = 0 

''Consolidados 
Set excelTable1 = Worksheets("TDCSD").Range("N280:U287") 
Set excelTable2 = Worksheets("TDEXITO").Range("N48:U55") 
Set excelTable3 = Worksheets("TDGPA").Range("N81:U88") 
Set excelTable4 = Worksheets("TDSACI").Range("N234:U241") 
Set excelTable5 = Worksheets("TDSMU").Range("N47:U54") 
Set excelTable6 = Worksheets("TDRPLY").Range("N76:U83") 
Set excelTable7 = Worksheets("TDInR").Range("N44:U51") 
Set excelTable8 = Worksheets("TDPA").Range("N59:U66") 
Set excelTable9 = Worksheets("TDIRSA").Range("N31:U38") 
Set excelTable10 = Worksheets("TCOM").Range("Q8:AC17") 
Set excelTable11 = Worksheets("TCOM").Range("Q24:AC33") 


'SLIDES 

'Slide 0 

Set pptSlide = pptPres.Slides.Add(1, ppLayoutTitle) 

SlideTitle = ThisWorkbook.Sheets("PPT").Range("F7").Value 
pptSlide.Shapes(1).TextFrame.TextRange.Text = SlideTitle 

pptSlide.Shapes.Title.TextFrame.TextRange.Characters(Start:=36, Length:=65).Font.Size = 20 
pptSlide.Shapes.Title.Width = 610 

pptSlide.Shapes(2).TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B7").Value 

'Agregar el número de diapositiva en la esquina derecha: 
Set pptTextbox = pptSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 686, 510, 34, 29) 

With pptTextbox.TextFrame 
    .TextRange.InsertSlideNumber 
    .TextRange.Font.Size = 8 
    .TextRange.Font.Name = "Tahoma" 
    .TextRange.Font.Color = RGB(137, 137, 137) 
    .VerticalAnchor = msoAnchorMiddle 
End With 



'Slide 1: 

Set pptSlide = pptPres.Slides.Add(2, ppLayoutCustom) 
SlideTitle = "Introducción" 
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle 
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22 


Set pptTextbox = pptSlide.Shapes(1) 

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B11").Value 
pptTextbox.Top = 88 
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify 

'Agregar el número de diapositiva: 
Set pptTextbox = pptSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 686, 510, 34, 29) 

With pptTextbox.TextFrame 
    .TextRange.InsertSlideNumber 
    .TextRange.Font.Size = 8 
    .TextRange.Font.Name = "Tahoma" 
    .TextRange.Font.Color = RGB(137, 137, 137) 
    .VerticalAnchor = msoAnchorMiddle 
End With 




'Slide 2: 
Set pptSlide = pptPres.Slides.Add(3, ppLayoutTitleOnly) 
SlideTitle = "Agenda" 
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle 
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22 

Set pptTextbox = pptSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 686, 510, 34, 29) 

With pptTextbox.TextFrame 
    .TextRange.InsertSlideNumber 
    .TextRange.Font.Size = 8 
    .TextRange.Font.Name = "Tahoma" 
    .TextRange.Font.Color = RGB(137, 137, 137) 
    .VerticalAnchor = msoAnchorMiddle 
End With 


'Slide 3: 
''Crear Slide y añadir título 
Set pptSlide = pptPres.Slides.Add(4, ppLayoutCustom) 
SlideTitle = "Noticias Relevantes" 
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle 
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22 

''Insertar el texto desde Excel 
Set pptTextbox = pptSlide.Shapes(1) 

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B24").Value 
pptTextbox.Top = 68.8 
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify 

''Añadir número de Slide 
Set pptTextbox = pptSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 686, 510, 34, 29) 

With pptTextbox.TextFrame 
    .TextRange.InsertSlideNumber 
    .TextRange.Font.Size = 8 
    .TextRange.Font.Name = "Tahoma" 
    .TextRange.Font.Color = RGB(137, 137, 137) 
    .VerticalAnchor = msoAnchorMiddle 
End With 

'Añadir imagenes 
'Falabella 
Sheets("IMG").Shapes("Picture 1").Copy 
pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select 
pptSlide.Shapes(4).Width = 121 
pptSlide.Shapes(4).Height = 51 
pptSlide.Shapes(4).Left = 579.4 
pptSlide.Shapes(4).Top = 3.4 


'Slide 4: 
''Crear Slide y añadir el título 
Set pptSlide = pptPres.Slides.Add(5, ppLayoutCustom) 
SlideTitle = "Noticias Relevantes" 
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle 
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22 

''Añadir texto 
Set pptTextbox = pptSlide.Shapes(1) 

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B49").Value 
pptTextbox.Top = 77 
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify 

''Añadir número de Slide 
Set pptTextbox = pptSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 686, 510, 34, 29) 

With pptTextbox.TextFrame 
    .TextRange.InsertSlideNumber 
    .TextRange.Font.Size = 8 
    .TextRange.Font.Name = "Tahoma" 
    .TextRange.Font.Color = RGB(137, 137, 137) 
    .VerticalAnchor = msoAnchorMiddle 
End With 

''Añadir imagenes 
'Grupo Éxito 
Sheets("IMG").Shapes("Picture 2").Copy 

pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture) 
pptSlide.Shapes(4).Width = 108 
pptSlide.Shapes(4).Height = 65 
pptSlide.Shapes(4).Left = 592 
pptSlide.Shapes(4).Top = 1.42 

Answer 1

좋은 전화. 내가 실제로 선택한 유일한 시간은 의도적으로 사용자를 탭/셀로 안내 할 때입니다.

어떻게 이것에 대해 :

Dim s As Shape 
Dim ws As Worksheet 

Set ws = ThisWorkbook.Worksheets("IMG") 
Set s = ws.Shapes("Picture 1") 

s.Copy 

을 물론 당신이 할 수 워크 시트의 각 모양을 반복 :

for each s in ws.shapes 
    debug.print s.name 
    s.copy 
    'Code for pasting the image 
next s 

행운을 빕니다! 희망이 도움이됩니다!

Answer 2

Excel 워크 시트 (Select 제외)에서 이미지를 복사하고 PowerPoint 슬라이드에 붙여 넣으려면 아래 코드를 사용하십시오.

주 : 나는 부분은 당신이 당신의 PowerPoint 프레젠테이션을-설정하고 당신을 위해 pptSlide 작품을 설정하고 남아있는 유일한 것은 복사입니다 >> 이미지를 붙여 가정합니다.

코드

Option Explicit 

Sub CopyPic_to_PPT() 

Dim pptSlide As PowerPoint.Slide 
Dim myPic As Object              

Sheets("IMG").Shapes("Picture 1").Copy '<-- copy the "Picture 1" image from "IMG" worksheet 

' set myPic to current pasted shape in PowerPoint 
Set myPic = pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse) 

' modify current pic setting 
With myPic 
    .Width = 121 
    .Height = 51 
    .Left = 580 
    .Top = 3 
End With 

End Sub 

추가 (안전한 모드) : 당신이 "IMG"워크 시트에있는 모든 Shapes을 통해 루프를 원한다면, 그것은 "그림 1"의 경우 각 도형의 이름을 확인, 만 이 모양을 PowerPoint 슬라이드에 복사 한 다음 아래 코드를 사용하십시오.

Dim CurShape As Object 

' loop through all shapes in "IMG" worksheet 
For Each CurShape In Sheets("IMG").Shapes 
    If CurShape.Name Like "Picture 1" Then ' if current shape's name = "Picture 1", then copy 
     CurShape.Copy 
     Exit For 
    End If 
Next CurShape