Господа, доброго времени суток! Столкнулся с определенной проблемой в VBA Power Point и вновь обращаюсь к Вам.
Есть макрос в Power Point который при выполнении ищет данные в папках, отталкиваясь от того какая сегодня дата. Стоит задача убрать привязку к дате и сделать ручной ввод даты. Проблема в том что дат там много и у всех разный формат. (Input Box не подходит)
В Excel данную проблему я решил через запись
[vba]
Код
Windows ("file.xlsm").Activate Sheets("Sheet1").Select new_date = Range("AE35").Value
[/vba]
При такой же вставке получил ошибку
Compile error: Sub or function not defined
В общем то ожидаемо.
Подскажите пожалуйста какую "оговорку" сделать в коде чтобы Power Point мог брать дату из соответствующей ячейки Excel?
С уважением, Slym
P.S. Код не выделяю через #, т.к. почему то криво отображается в теме...
Господа, доброго времени суток! Столкнулся с определенной проблемой в VBA Power Point и вновь обращаюсь к Вам.
Есть макрос в Power Point который при выполнении ищет данные в папках, отталкиваясь от того какая сегодня дата. Стоит задача убрать привязку к дате и сделать ручной ввод даты. Проблема в том что дат там много и у всех разный формат. (Input Box не подходит)
В Excel данную проблему я решил через запись
[vba]
Код
Windows ("file.xlsm").Activate Sheets("Sheet1").Select new_date = Range("AE35").Value
[/vba]
При такой же вставке получил ошибку
Compile error: Sub or function not defined
В общем то ожидаемо.
Подскажите пожалуйста какую "оговорку" сделать в коде чтобы Power Point мог брать дату из соответствующей ячейки Excel?
С уважением, Slym
P.S. Код не выделяю через #, т.к. почему то криво отображается в теме...Slym1349
Сообщение отредактировал Slym1349 - Вторник, 21.04.2020, 16:13
Application.EnableEvents = True 'objPPFile.Close Set objPPFile = Nothing Set objPP = Nothing
End Sub
[/vba]
В этой части привязку к ручному вводу даты можно задать без проблем. В макросе Power Point же привязка к дате идет следующим образом:
[vba]
Код
... ' Для понедельника и вторника
If Weekday(Date) = 2 Or Weekday(Date) = 3 Or Weekday(Date) = 4 Then a = Format(Date - 5, "DD.MM.YYYY") b = Format(Date - 5, "YYYYMMDD") c = Format(Date, "DD.MM.YYYY") d = Format(Date - 5, "YYMMDD") e = Format(Date - 5, "YYYY") f = Format(Date - 5, "YYYY_MM") g = Format(Date - 5, "MM") Z = "год"
' Для среды, четверга и пятницы
Else a = Format(Date - 3, "DD.MM.YYYY") b = Format(Date - 3, "YYYYMMDD") c = Format(Date, "DD.MM.YYYY") d = Format(Date - 3, "YYMMDD") e = Format(Date - 3, "YYYY") f = Format(Date - 3, "YYYY_MM") g = Format(Date - 3, "MM") Z = "год"
End If
...
[/vba]
Сам макрос вставлять не буду - там идут команды на изменение строк на слайдах, вставку новых слайдов и т.д. Пути к слайдам и даты в строках задаются вышеуказанными переменными.
Если нужно я конечно укажу его целиком, просто он большой + придется менять все пути т.к. на работе строго с безопасностью.
Вот. Собственно вопрос в том как отвязать даты от функции Date и задавать их таблицей в Excel.
Т.к. все даты отчетности строго по рабочим дням и в Excel можно настроить трудовой календарь, а функции Date безразлично выходной сейчас день или нет.
С уважением, Slym
Извините за долгий ответ
Смотрите сам макрос Power Point'a запускается из файла Excel, вот так:
[vba]
Код
Dim objPP As Object Dim objPPFile As Object
Set objPP = CreateObject("PowerPoint.Application") objPP.Visible = True
Application.EnableEvents = True 'objPPFile.Close Set objPPFile = Nothing Set objPP = Nothing
End Sub
[/vba]
В этой части привязку к ручному вводу даты можно задать без проблем. В макросе Power Point же привязка к дате идет следующим образом:
[vba]
Код
... ' Для понедельника и вторника
If Weekday(Date) = 2 Or Weekday(Date) = 3 Or Weekday(Date) = 4 Then a = Format(Date - 5, "DD.MM.YYYY") b = Format(Date - 5, "YYYYMMDD") c = Format(Date, "DD.MM.YYYY") d = Format(Date - 5, "YYMMDD") e = Format(Date - 5, "YYYY") f = Format(Date - 5, "YYYY_MM") g = Format(Date - 5, "MM") Z = "год"
' Для среды, четверга и пятницы
Else a = Format(Date - 3, "DD.MM.YYYY") b = Format(Date - 3, "YYYYMMDD") c = Format(Date, "DD.MM.YYYY") d = Format(Date - 3, "YYMMDD") e = Format(Date - 3, "YYYY") f = Format(Date - 3, "YYYY_MM") g = Format(Date - 3, "MM") Z = "год"
End If
...
[/vba]
Сам макрос вставлять не буду - там идут команды на изменение строк на слайдах, вставку новых слайдов и т.д. Пути к слайдам и даты в строках задаются вышеуказанными переменными.
Если нужно я конечно укажу его целиком, просто он большой + придется менять все пути т.к. на работе строго с безопасностью.
Вот. Собственно вопрос в том как отвязать даты от функции Date и задавать их таблицей в Excel.
Т.к. все даты отчетности строго по рабочим дням и в Excel можно настроить трудовой календарь, а функции Date безразлично выходной сейчас день или нет.
Вариант может быть такой: -- для первого слайда рисуем надпись, но рисуем не на слайде, а за пределами, скажем выше или правее, т.е при демонстрации она не будет видна -- можно назвать её как-то, например DateExcel -- из макроса Excel в эту надпись отправляем содержимое ячейки типа [vba]
[/vba] -- в макросе PowerPoint считываем дату из этой надписи [vba]
Код
a = Format(CDate(Slide1.Shapes("DateExcel").TextFrame.TextRange.Text) - 5, "DD.MM.YYYY")
[/vba]
Вариант может быть такой: -- для первого слайда рисуем надпись, но рисуем не на слайде, а за пределами, скажем выше или правее, т.е при демонстрации она не будет видна -- можно назвать её как-то, например DateExcel -- из макроса Excel в эту надпись отправляем содержимое ячейки типа [vba]
'запускаю в открытой презе макрос "Dates_Copies_PDF" прописанный в модуле под названием "Daily" objPP.Run old_date & "_presentation_daily.pptm!Daily.Dates_Copies_PDF"
Application.EnableEvents = True
Set objPPFile = Nothing
Set objPP = Nothing
End Sub
[/vba]
Макрос прописанный в Power Point
[vba]
Код
Sub Dates_Copies_PDF()
Dim excelApplication As Object Set excelApplication = GetObject(, "Excel.Application") excelApplication.Visible = True
Dim a As String Dim b As String
'получаем наши даты из Excel a = excelApplication.ActiveWorkbook.Sheets("sheet1").Range("AF39").Value ' DD.MM.YYYY b = excelApplication.ActiveWorkbook.Sheets("sheet1").Range("AE39").Value ' YYYYMMDD
Set excelApplication = Nothing
'Используем полученные переменные для работы в Power Point
'Обновление дат на первом слайде (для того чтобы узнать номер формы: Кликаем на форму - формат - область выделения(область навигации) - справа будет список всех форм, нумерация ведется СНИЗУ)
ActivePresentation.Slides(1).Shapes(3).TextFrame.TextRange.Lines(4).Text = "Отчёт на " & a ActivePresentation.Slides(1).Shapes(4).TextFrame.TextRange.Lines(5).Text = "Дата подготовки отчёта: " & b
'Добавляем два слайда из другой презы
On Error GoTo 0 On Error Resume Next Presentations.Open fileName:="N:\box\" & a & "_" & b & "\" & a & "_ нарушения.pptx", ReadOnly:=msoFalse
'прописываем открыть папку если другая преза не найдена
If Err.Number <> 0 Then MsgBox ("Преза не найдена – открою папку в которой она должна лежать") Call Shell("explorer.exe" & " " & "N:\box\" & a & "_" & b & "\", vbNormalFocus) Err.Clear
Else ActivePresentation.Slides.Range(Array(1, 2)).Copy ‘если нужно забрать только 1 слайд то заменить эту строку на ActivePresentation.Slides(1).Copy
With Application.Presentations(a & "_нарушения.pptx") .Saved = True .Close End With
ActiveWindow.View.Paste
' передвигаем первый слайд на нужное место ActivePresentation.Slides(2).MoveTo toPos:=8
' передвигаем второй слайд на нужное место (т.к. первый уже "уехал" то второй попадает на второе место) ActivePresentation.Slides(2).MoveTo toPos:=9
End If
' Сохраняем обновленную презентацию под новым именем
ActivePresentation.SaveAs ActivePresentation.Path & "\" & b & "_presentation_daily" & ".pptm"
End Sub
[/vba]
Как то так
Pelena, извините не увидел Ваше сообщение и как итог не проверял, потому что решил сам.
Для других пользователей кто столкнется с подобной проблемой выкладываю сюда РЕШЕНИЕ, дабы сэкономить Ваше время.
В общем задачу удалось решить через функцию Create Object, выкладываю код
В Excel
[vba]
Код
Sub Run_power_point()
'даем ссылку на даты внесенные в конкретную ячейку (даты использую формата YYYYMMDD) Windows("book.xlsm").Activate Sheets("sheet1").Select old_date = Range("AE43").Value new_date = Range("AE39").Value
Set objPP = CreateObject("PowerPoint.Application")
'запускаю в открытой презе макрос "Dates_Copies_PDF" прописанный в модуле под названием "Daily" objPP.Run old_date & "_presentation_daily.pptm!Daily.Dates_Copies_PDF"
Application.EnableEvents = True
Set objPPFile = Nothing
Set objPP = Nothing
End Sub
[/vba]
Макрос прописанный в Power Point
[vba]
Код
Sub Dates_Copies_PDF()
Dim excelApplication As Object Set excelApplication = GetObject(, "Excel.Application") excelApplication.Visible = True
Dim a As String Dim b As String
'получаем наши даты из Excel a = excelApplication.ActiveWorkbook.Sheets("sheet1").Range("AF39").Value ' DD.MM.YYYY b = excelApplication.ActiveWorkbook.Sheets("sheet1").Range("AE39").Value ' YYYYMMDD
Set excelApplication = Nothing
'Используем полученные переменные для работы в Power Point
'Обновление дат на первом слайде (для того чтобы узнать номер формы: Кликаем на форму - формат - область выделения(область навигации) - справа будет список всех форм, нумерация ведется СНИЗУ)
ActivePresentation.Slides(1).Shapes(3).TextFrame.TextRange.Lines(4).Text = "Отчёт на " & a ActivePresentation.Slides(1).Shapes(4).TextFrame.TextRange.Lines(5).Text = "Дата подготовки отчёта: " & b
'Добавляем два слайда из другой презы
On Error GoTo 0 On Error Resume Next Presentations.Open fileName:="N:\box\" & a & "_" & b & "\" & a & "_ нарушения.pptx", ReadOnly:=msoFalse
'прописываем открыть папку если другая преза не найдена
If Err.Number <> 0 Then MsgBox ("Преза не найдена – открою папку в которой она должна лежать") Call Shell("explorer.exe" & " " & "N:\box\" & a & "_" & b & "\", vbNormalFocus) Err.Clear
Else ActivePresentation.Slides.Range(Array(1, 2)).Copy ‘если нужно забрать только 1 слайд то заменить эту строку на ActivePresentation.Slides(1).Copy
With Application.Presentations(a & "_нарушения.pptx") .Saved = True .Close End With
ActiveWindow.View.Paste
' передвигаем первый слайд на нужное место ActivePresentation.Slides(2).MoveTo toPos:=8
' передвигаем второй слайд на нужное место (т.к. первый уже "уехал" то второй попадает на второе место) ActivePresentation.Slides(2).MoveTo toPos:=9
End If
' Сохраняем обновленную презентацию под новым именем
ActivePresentation.SaveAs ActivePresentation.Path & "\" & b & "_presentation_daily" & ".pptm"