在Excel中複製一個範圍在Excel中粘貼

Question

我有這個代碼複製一個叫做pastedpic 19的形狀，這是我的Excel文件中的形狀17，然後打開一個新的PowerPoint幻燈片並粘貼它。問題是我希望它被複製爲正常範圍和粘貼作爲這個副本，所以我可以在那裏更改數據。

Sub exceltoPPT() 

Dim PowerPointapp as Object 
Dim myPresentation As Object 
Dim mySlide As Object 
Dim myShape As Object 
Dim DestinationSheet7 As Worksheet 
Dim DestinationSheet1 As Worksheet 

Dim pastedPic3 As Shape 

Set DestinationSheet1 = Workbooks("1_1_1_tt.xlsm").Sheets("Eingabefeld") 
Set pastedPic9 = DestinationSheet1.Shapes(17) 


' Create a New Presentation 
    Set myPresentation = PowerPointApp.Presentations.Add 

'Add a slide to the Presentation 
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly 


'pastedPic9.Copy 
    Windows(anan).Activate 

    Sheets("Eingabefeld").Range("B1:ES44").CopyPicture Appearance:=xlPrinter,Format:=xlPicture 

'Paste to PowerPoint and position 
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile 
Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 

'Set position: 
    myShape.Left = -15 

    myShape.Top = 11 

End Sub 

有沒有人知道如何做到這一點？

Answer 1

試試這個

Sub Export_xls2pp() 
' 
'======================================================================================= 
' Procedure : Export_xls2pp (Sub) 
' Module : Module1 (Module) 
' Project : VBAProject 
' Author : yann LE DIRACH 
' Date  : 11/03/2016 
' Comments : eXPORT XLS RANGE INTO POWERPOINT TABLE 
'    ADD REFERENCE TO POPERPOINT LIBRARY (EARLY BINDING) 
' Unit Test :() 11/03/2016 10:11 | Description [OK] 
' Arg./i : 
'   - [NO PARAM] 
'   - 
'   - 
' Arg./o :() 
' 
'Changes-------------------------------------------------------------------------------- 
'Date    Programmer      Change 
'11/03/2016   yann LE DIRACH    Initiate 
' 
'======================================================================================= 
' 
Dim opp As PowerPoint.Application 
Dim oppp As PowerPoint.Presentation 
Dim oppps As PowerPoint.Slide 
Dim opps_s As PowerPoint.Shape 
Dim opps_t As Table 
Dim orng As Range 

'Note : current xls range 
Set orng = ActiveSheet.Range("A1:C6") 

'Note : add powerpoint doc 
Set opp = CreateObject("Powerpoint.Application") 
Set oppp = opp.Presentations.Add 

With oppp 
    'Note : add slide 
    Set oppps = .Slides.Add(1, ppLayoutBlank) 
    With oppps 
     'Note : add slide > set to table > dim table with xls range settings 
     Set opps_s = .Shapes.AddTable(orng.Rows.Count, orng.Columns.Count) 
     Set opps_t = opps_s.Table 
     'Note : loop throught rng and populate powerpoint table 

     For i = 1 To orng.Rows.Count 
      For j = 1 To orng.Columns.Count 
       opps_t.Cell(i, j).Shape.TextFrame.TextRange.Text = orng.Cells(i, j).Value 

      Next j 
     Next i 

    End With 
End With 

End Sub