Копирование чартов из Excel в PowerPoint - VBA - Ответ 1333936

@Belthazor4 · 01.02.2011, 15:23 **[ТС]**

Вот собственно код функции, которая это делает

Visual Basic

Public Function CopyChart(ByVal PPApp, ByVal PPPres, sheet, ChartName, awidth, aheight, atop, aleft, title)
    sheet.Select
    Dim PPSlide
    Dim exc
    Dim fromsht, datasht
    Set fromsht = ActiveSheet
    Set datasht = ThisWorkbook.Worksheets(VBA.Mid(ActiveSheet.name, InStr(ActiveSheet.name, ".") + 2) + " data")
    Set exc = Workbooks.Add
    Application.DisplayAlerts = False
    exc.Sheets(2).Delete
    exc.Sheets(2).Delete
    Application.DisplayAlerts = True
    
    fromsht.ChartObjects(ChartName).chart.ChartArea.Copy
    exc.Sheets(1).Paste
    UnprotectSht datasht
    datasht.Visible = True
    datasht.Copy After:=exc.Sheets(1)
    exc.Sheets(2).PivotTables(1).TableRange2.Clear
    datasht.Visible = False
    ProtectSht datasht
    
    ActiveWorkbook.ChangeLink name:=fromsht.Parent.name, NewName:=exc.name, _
        Type:=xlExcelLinks
    
    PPApp.ActiveWindow.ViewType = 1 'ppViewSlide
    PPApp.ActiveWindow.View.GotoSlide (PPPres.Slides.Count)
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    exc.Sheets(1).ChartObjects(ChartName).Activate
    ActiveChart.ChartArea.Copy
    PPSlide.Select
    PPSlide.Shapes.PasteSpecial Link:=msoTrue '----- вот здесь надо что то вставить =)
    PPSlide.Select
    PPSlide.Shapes(PPSlide.Shapes.Count).Select
    Application.DisplayAlerts = False
    exc.Close
    Application.DisplayAlerts = True
    Dim sr
    Set sr = PPApp.ActiveWindow.Selection.ShapeRange
    sr.width = awidth
    sr.height = aheight
    sr.top = atop
    sr.left = aleft
    Set PPSlide = Nothing
    Set sr = Nothing
End Function

а вызывается она из чего то типа такого

Visual Basic

Sub GoPPT()
    Dim PPApp, PPPres, filetoopen, pres1, flag
    filetoopen = Application.GetOpenFilename("PowerPoint Presentations, *.*")
    If filetoopen = False Then
        MsgBox "Не выбрано"
        Exit Sub
    Else:
        Set PPApp = CreateObject("Powerpoint.application")
        PPApp.Visible = True
        flag = 0
        For Each pres1 In PPApp.Presentations
            If pres1.FullName = filetoopen Then
                Set PPPres = pres1
                flag = 1
            End If
        Next pres1
        If flag = 0 Then Set PPPres = PPApp.Presentations.Open(filetoopen)
        MakePP PPApp, PPPres, ThisWorkbook.ActiveSheet
    End If
    Set PPApp = Nothing
    Set PPPres = Nothing
End Sub

Visual Basic

Sub MakePP(ByVal PPApp, ByVal PPPres, ByVal sht)
    Dim obj, flag, i, k, arr1()
    arr1 = Array("tvr", "stvr", "num")
    AddSlide PPApp, PPPres
    CopyChart PPApp, PPPres, sht, "main", 560, 320, 120, 80, ""    'sht.Range("b6").value
End Sub

почему так жестко все лагает?? оч долго все происходит. Я так заметил, что с PP плохо сообщается макрос из экселя, другие варианты комбинации всяких там activate'ов тупо вызывают ошибки, код может у меня плоховат???

Добавлено через 8 минут

а как вы вручную вставляете и вас устраивает эта вставка - напишите порядок действий, который вы делаете.

В общем так - я создаю новый ексельник, туда копирую тупо лист с данными, на другой чистый лист я копирую график с ссылкой на файл с макросом, потом переделываю кнопочкой "Edit links" в меню ссылки с одной книги на новую созданную, потом я жму ctrl-c с выделенным графиком новой книги, переключай на PP жму правой кнопкой и выбираю где pastespecial вариант Use destination theme & Embed workbook (H). после этого офис всовывает в файл с презентацией этот созданный темповый эксельник (можно проверить, переименовав .pptx в .zip и там он будет лежать). после этого когда тыкаешь правой кнопкой на график в PP и выбираешь меню Edit data открывается собственно этот вшитый эксельник отдельным окном и там можно менять данные. Вот собственно так.

Вернуться к обсуждению:
Копирование чартов из Excel в PowerPoint VBA

Следующий ответ

Другие темы раздела
VBA По введенному времени определить количество часов до конца дня. По введенному времени определить количество часов до конца дня. https://www.cyberforum.ru/ vba/ thread236548.html	Заполнение документа скриптом vba VBA Добрый день. Имеется шаблон документа , в котором имеется две таблицы (таблица №1 и таблица №2). Каждая таблица поочередно увеличивается на одну строку путем копирования предыдущей строки и ее вставки (количество повторений данного цикла можно взять любым - главное, чтобы заполнилось не менее одной страницы) . Необходимо, чтобы по окончании текущей страницы, на новую страницу вставлялся исходный...
VBA Считаю запятые https://www.cyberforum.ru/ vba/ thread236165.html Как рассматривать каждый символ в строке отдельно? Dim TestString As String TestString = "1-3,5-7,10-20" t = 1 n = Len(TestString) For i = 0 To n - 1 If TestString(i) = "," Then t = t + 1 End If	VBA Опустошение строки выпадающего списка. Доброго времени суток, господа форумчане! Имеется следующая задача: Внутри двух выпадающих списков имеются некоторые диапазоны из другого листа. Списки привязаны к ячейкам А2 и В2 листа maintab. Также имеется кнопка на листе maintab, при нажатии на которую выполняется следующий код: Sub Кнопка3_Щелчок() 'объявление двух переменных Dim engine As Integer https://www.cyberforum.ru/ vba/ thread235990.html
VBA RecordSet Вот код, он должен выполнять поиск на форме по полю со списком Private Sub Поле38_AfterUpdate() Dim rs As Recordset Dim crit As String Set rs = Me.RecordsetClone crit = "= " & Поле38.Value rs.FindFirst crit If Not rs.NoMatch = True Then Me.Bookmark = rs.Bookmark	VBA Подчеркивание второй буквы в третьем слове пятого абзаца активного документа https://www.cyberforum.ru/ vba/ thread235901.html 'подчеркивание второй буквы в третьем слове пятого абзаца активного документа ActiveDocument.Paragraphs(5).Range.Words(3).Characters(2).Font.Underline = wdUnderline-Single а как будет если в этом слове надо подчеркнуть несколько букв подряд??, известно, что три последних, если не подряд?? Мне нужно без выделения слова Спасибо
VBA Как изменить индекс у элемента управления? https://www.cyberforum.ru/ vba/ thread235819.html как изменить индекс у элемента управления, чтобы циклом сделать нужные элементы управления видимыми? Можно ли создать массив элементов управления?	VBA сравнение а (эй) и а Скажите, пожалуйста, как можно сделать так, чтобы макрос при сравнении букв а (эй) и а не учитывал что это разные буквы (русская и английская), а сравнивал а = а
VBA Вычисление определителя и нахождение обратной матрицы методом исключения https://www.cyberforum.ru/ vba/ thread235539.html Нужна только блок-схема, а то в схемах я пень пнем. Вот код. Function input_error() As Integer ' err – идентификатор ошибки Dim err, degree As Integer err = 0 degree = Worksheets("Лист1").Range("A6").Value	VBA Макрос для сверки значений двух столбцов https://www.cyberforum.ru/ vba/ thread235503.html Помогите, пожалуйста исправить макрос так, чтобы ускорился процесс сверки значений из 2-ух столбцов. Макрос во вложении. Если в файле 5000 строк, то сейчас он работает очень долго.
VBA Ввести текст из нескольких слов и вывести слово в котором чаще всего встречается буква Нужно ввести текст, затем ввести букву. Прога должна выдать слово в котором чаще всего встречается эта буква	VBA Задать формат рисунка Вставляю в колонтитулы рисунок: ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader Selection.InlineShapes.AddPicture FileName:=Лого.Text, _ LinkToFile:=False, SaveWithDocument:=True Но, как всегда делает ворд, он делает так, как хочется ему. Результат - колонтитулы раком. Весь многостраничный документ тоже. Не могу побороть: как при вставке указать формат картинки -... https://www.cyberforum.ru/ vba/ thread235446.html

	01.02.2011, 15:23