파워 포인트에 엑셀 데이터를 붙여 넣는 방법 사용자가 데이터를 편집 할 수있게하는 방법

Question

사용자가 결과를 편집 할 수있게하면서 엑셀 범위를 엑셀 포인트로 내보내거나 붙여 넣는 방법이 있는지 궁금합니다. 인터넷에서 계속 볼 수있는 코드는 파워 포인트에 대한 탁월한 데이터를 그림으로 붙여 넣습니다. 아래 예가 있습니다 :

Sub export_to_ppt(ByVal sheetname As String, ByVal initialSelection As String) ', ByVal cols As Integer, ByVal rows As Integer) 

Application.ScreenUpdating = False 
Dim rng As Range 
Dim PowerPointApp As Object 
Dim myPresentation As Object 
Dim mySlide As Object 
Dim myShape As Object 

'Copy Range from Excel 
'Set rng = ThisWorkbook.ActiveSheet.Range("B17:D50") 

'Create an Instance of PowerPoint 
On Error Resume Next 

'Is PowerPoint already opened? 
Set PowerPointApp = GetObject(class:="PowerPoint.Application") 

'Clear the error between errors 
Err.Clear 

'If PowerPoint is not already open then open PowerPoint 
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 

'Handle if the PowerPoint Application is not found 
If Err.Number = 429 Then 
    MsgBox "PowerPoint could not be found, aborting." 
    Exit Sub 
End If 

On Error GoTo 0 

'Optimize Code 
Application.ScreenUpdating = False 

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

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

'Copy Excel Range 

Dim rowCount As Integer 
Dim colcount As Integer 
Dim i As Integer 
Dim No_sheets As Integer 
No_sheets = Worksheets("Control_Sheet").Range("AP2").Value + 2 

For i = 3 To No_sheets 
Worksheets("Control_Sheet").Activate 
Worksheets("Control_Sheet").Cells(i, 42).Select 
    If Worksheets("Control_Sheet").Cells(i, 42).Value = sheetname Then 

     rowCount = Worksheets("Control_Sheet").Cells(i, 44).Value 
     colcount = Worksheets("Control_Sheet").Cells(i, 43).Value 
     GoTo resume_copy 
    End If 
Next i 

resume_copy: 
Worksheets(sheetname).Activate 
Worksheets(sheetname).Range(initialSelection).Select 
Selection.Resize(rowCount, colcount).Select 
Selection.Copy 


'Paste to PowerPoint and position 
Application.Wait Now + TimeValue("00:00:01") 
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile 
Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 

'Set position: 
myShape.Left = 1 
myShape.Top = 1 
myShape.Width = 950 
PowerPointApp.Visible = True 
PowerPointApp.Activate 

Application.CutCopyMode = False 
Application.ScreenUpdating = True 

End Sub 

Answer 1

교체 :

mySlide.Shapes.PasteSpecial DataType:=2 

로 :이 도움이

mySlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse, link:=msoFalse 

희망, TheSilkCode

Answer 2

큰 ppt 데크를 실행할 때이 프로세스는 매우 버그가 있습니다. 이 작업은 ppt shape 위치를 붙여 넣기 위치로 사용합니다. 템플릿 ppt 슬라이드를 사용하여 테스트하면 테이블과 그래프를 이런 식으로 붙여 넣을 수 있습니다.

Dim myApp As PowerPoint.Application 
    Dim myPres As PowerPoint.Presentation 
    Dim myStatsSlide As PowerPoint.Slide 

    Set myApp = New PowerPoint.Application 
    Set myPres = myApp.ActivePresentation 

    Set myStatsSlide = myPres.Slides(1) 

    Dim mySheet As Worksheet 
    Set mySheet = ActiveSheet 

    'Copy table as table, not image 
    Dim mySumTable As Range 
    Set mySumTable = mySheet.Range("A1:C5") 

    mySumTable.Copy 

    myStatsSlide.Shapes.Placeholders(1).Select 

    myPres.Windows(1).View.Paste 

    'Copy Chart, as chart not image 
    Dim monoChart As ChartObject 

    'MONO CHART 
    monoChart.Select 
    ActiveChart.ChartArea.Copy 

    Debug.Print monoChart.Name 


    myStatsSlide.Shapes.Placeholders(2).Select 

    myPres.Windows(1).View.Paste 

    Debug.Print monoChart.Name