How to paste the excel chart into power point without linking with Data

[Thanish]

Hello Team,

I have around 30 charts in excel sheet. I would like to copy and paste the same into the powerpoint(6 charts per slide).

While pasting the chart into powerpoint slide, the system is linking the chart automatically.

Is there any possible way to copy and paste the excel chart into powerpoint slide without linking to excel.

I will change the x-axis and y-axis alone in the powerpoint depend upon the data.

PS: I'm not interested to paste the chart as image.

Please save me in spending more than 5 hours in a day.

Thanks
T

 

[Worf]

Hello

Dim acslide As Slide, pres As Presentation, newPP As PowerPoint.Application

Sub Six_Per_Slide()                                        ' run me
Dim i%, j%, cht1 As Excel.ChartObject, _
Data As Worksheet, sld As Slide, shp As PowerPoint.Shape
On Error Resume Next
Set newPP = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPP Is Nothing Then Set newPP = New PowerPoint.Application
If newPP.Presentations.Count = 0 Then newPP.Presentations.Add
newPP.Visible = True
Set pres = newPP.ActivePresentation
AddOne
Set Data = ActiveSheet
For i = 1 To Data.ChartObjects.Count
    JustDoIt IIf(i > 6, i Mod 6, i)
    If i Mod 7 = 0 Then
        JustDoIt 6
        AlignCharts 6                                       ' slide has six charts
        AddOne
    End If
    Set cht1 = Data.ChartObjects(i)
    MsgBox cht1.Name, 64, i
    JustDoIt IIf(i > 6, i Mod 6, i)
    cht1.Copy
    newPP.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
    JustDoIt IIf(i > 6, i Mod 6, i)
Next
AlignCharts Data.ChartObjects.Count Mod 6                   ' last slide
AppActivate newPP.Caption
On Error Resume Next
For Each sld In pres.Slides
    For Each shp In sld.Shapes
        shp.LinkFormat.BreakLink
    Next
Next
Set acslide = Nothing:  Set newPP = Nothing
On Error GoTo 0
End Sub

Sub AddOne()                                                ' new slide is needed
DoEvents
pres.Slides.Add pres.Slides.Count + 1, ppLayoutText
newPP.ActiveWindow.View.GotoSlide pres.Slides.Count
Set acslide = pres.Slides(pres.Slides.Count)
Do While acslide.Shapes.Count > 0
    acslide.Shapes(acslide.Shapes.Count).Delete
Loop
End Sub

Sub AlignCharts(n%)
Dim j%
For j = 1 To n
    JustDoIt j
    acslide.Shapes(j).Height = pres.PageSetup.SlideHeight / 3
    acslide.Shapes(j).Width = pres.PageSetup.SlideWidth / 2
    Select Case j
        Case 1, 2: acslide.Shapes(j).Top = 0
        Case 3, 4: acslide.Shapes(j).Top = pres.PageSetup.SlideHeight / 3
        Case 5, 6: acslide.Shapes(j).Top = 2 * pres.PageSetup.SlideHeight / 3
    End Select
    Select Case j
        Case 1, 3, 5: acslide.Shapes(j).Left = 0
        Case 2, 4, 6: acslide.Shapes(j).Left = pres.PageSetup.SlideWidth / 2
    End Select
    DoEvents
Next
End Sub

Sub JustDoIt(i%)                        ' give Office some time...
Dim pptcht1 As PowerPoint.Shape, cnt%
On Error Resume Next
cnt = 0
Do
    DoEvents
    Set pptcht1 = acslide.Shapes(i)
    If Not pptcht1 Is Nothing Then Exit Do
    cnt = cnt + 1
    If cnt > 400 Then Exit Do
Loop
On Error GoTo 0
End Sub