таблицы Excel для PowerPoint VBA

Question

У меня есть стандартный код, который печатает все диаграммы на вашем активном листе в новое приложение PowerPoint:

Sub CreatePowerPoint()

'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505

    Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

Мне нужно изменить вместо активной таблицы всю книгу, поэтому скопируйте вседиаграммы в рабочей книге.Я попытался ввести то, что я использую, чтобы прочитать книгу и удалить все листы:

Sub ClearCharts()

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets

    For Each chtObj In wsItem.ChartObjects

        chtObj.Delete

    Next

Next

End Sub

, но он работает и не копирует диаграммы, когда я пытаюсь отредактировать строку активного листа.Любые идеи будут оценены для меня, чтобы прогрессировать.

Спасибо

Answer 1

В данный момент я пытаюсь сделать то же самое, глядя на код выше, у вас есть 3 для каждого цикла, но я думаю, у вас должно быть только 2. Один для циклического перемещения по листам, а второй для циклического перемещения по каждой диаграмме в листе.

Answer 2

`Sub SelectedSheetsPowerPoint ()

Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it


'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 75
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 120

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505
     'loop through each chart in !!activesheet!! and move each into a new slide!
    Next
'start pp, can add preset headings for power point here
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

DoEvents

Next
Next

End Sub

`

он пробегает и выводит все графики, но не останавливается, он будет просто копировать и циклически проходить по всем листам, пока я не закрою его после того, как он скопировал примерно 15 раз.

Answer 3

Вы должны активировать лист, прежде чем экспортировать диаграмму. Я сталкивался с этой проблемой в прошлом при экспорте диаграмм.

Попробуйте это

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets
    For Each chtObj In wsItem.ChartObjects

        wsItem.Activate

        '~~> Code here to copy it to the poerpoint
        '~~> Same for deleting it

        DoEvents

    Next
Next