Option Explicit
' Скрипт для преобразования диаграммы в PowerPoint в Таблицу Excel.
' Для работы скрипта включить (поставить галку) в VBA в главном меню:
' Tools -> References -> Microsoft Excel 15.0 Object Library
Sub From_Powerpoint_to_Excel()

' Номера слайда, фигуры, количество рядов (графиков) в PowerPoint.
' j - служебная переменная цикла
Dim SlideNum, ShapeNum, Collection, j As Integer
    SlideNum = 1
    ShapeNum = 1
    Collection = 3
    
' Номера строки, колонки, листа Excel.
Dim Rw, StCol, Col, Sht As Long
    Rw = 2     'Starting Row of Target excel data
    StCol = 2   'Starting Column of Target excel data
    Sht = 1   'Target Worksheet no.
    
Dim XLObj As Excel.Workbook
'Текущий путь
Dim sCurrentPath As String
sCurrentPath = ActivePresentation.Path
'Создаем новую книгу
Workbooks.Add
Set XLObj = ActiveWorkbook

'----- Основная часть
Dim pChart As Chart, Xs, Ys, i As Long, pSeries As Series
    ' Получаем данные из диаграммы
    Set pChart = ActivePresentation.Slides(SlideNum).Shapes(ShapeNum).Chart
    
    For j = 1 To Collection
    Set pSeries = pChart.SeriesCollection(j)
    Xs = pSeries.XValues: Ys = pSeries.Values
    ' Пишем заголовки
    XLObj.Sheets(Sht).Cells(1, 2).Value = "Данные для графика"
    XLObj.Sheets(Sht).Cells(Rw, StCol).Value = "X"
    XLObj.Sheets(Sht).Cells((Rw + 1), StCol).Value = "Y"
    StCol = StCol + 1
        ' Проходим по массиву данных из диаграммы
        For i = LBound(Xs) To UBound(Xs)
            ' Отладка
            Debug.Print "Point " & CStr(i) & " X = " & CStr(Xs(i)) & ", Y = " & CStr(Ys(i))
            ' Запись значений в ячейки чисел с десятичными дробями.
            'XLObj.Sheets(Sht).Cells(Rw, StCol).Value = CDbl(CStr(Xs(i)))
            'XLObj.Sheets(Sht).Cells((Rw + 1), StCol).Value = CDbl(CStr(Ys(i)))
            ' Запись значений в ячейки в виде строк.
            XLObj.Sheets(Sht).Cells(Rw, StCol).Value = CStr(Xs(i))
            XLObj.Sheets(Sht).Cells((Rw + 1), StCol).Value = CStr(Ys(i))
            StCol = StCol + 1
        Next i
        Rw = Rw + 2
        StCol = 2
    Next j
'-----
'Сохраняем книгу в папку, где расположен файл с кодом
ActiveWorkbook.SaveAs (sCurrentPath & "\Table1.xlsx")
'Закрываем файл
ActiveWorkbook.Close
MsgBox "Макрос заверщён. Реультат в файле Table1.xlsx"
End Sub