Блог

Я создал макрос VBA, который автоматически создает PowerPoint и тот, который создает рабочий лист с именем «Handlungsempfehlungen» с текстом. Рабочий лист «Handlungsempfehlungen» выглядит следующим образом:

https://i.stack.imgur.com/nZEL8.png

В нем около 40 столбцов (A-AO) и текст в каждом столбце от строки 1 до макс. 34 (количество строк, заполненных текстом, варьируется в каждом столбце). Теперь мне нужно каким-то образом перебирать каждую строку в каждом столбце и присваивать каждой ячейке.Значение существующему (и открытому в данный момент) PowerPoint. До сих пор я использовал что-то подобное для создания текстовых полей в PowerPoint и заполнения их значениями ячеек из Excel:

 'New PPslide (copy slide 2 which is emtpy)
Set PPslide = PPapp.ActivePresentation.Slides(2).Duplicate.Item(1)
'Put new slide to end of PP
PPslide.MoveTo (PPpres.Slides.Count)
'Change title
PPslide.Shapes.Title.TextFrame.TextRange = "Slidetitle"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Second title"
'Insert Textbox
Set PPtextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=40, Top:=133, Width:=875, Height:=30)
PPtextbox.TextFrame.TextRange.Text = ActiveWorkbook.Worksheets("Handlungsempfehlungen").Cells(1, 1).Value
 

Но с 40 столбцами и примерно 30 строками на столбец, каждый из которых заполнен текстом, мне нужно было бы создать около 1000 текстовых полей и передать их в мой PowerPoint. Как я мог бы перебирать этот лист и автоматически устанавливать позиции на слайде PowerPoint для каждого текстового поля? Заголовок слайда для каждого PowerPointslide уже сохранен в строке 35 каждого столбца на листе (см. Скриншот), поэтому я бы также передал это PP внутри цикла (для каждого столбца установите slidetitle = currentColumn .Строка 35 — это своего рода идея)

Моя текущая идея для всего этого заключается в том, что у меня есть 5 текстовых полей на слайд с заданными позициями, заполняя их значениями из строки 1-5 первого столбца, а затем создайте новый слайд и выполните тот же процесс для строк 6-10 и так далее, пока ячейка.Значение в текущем столбце не станет пустым, затемпереместите один столбец вправо и снова создайте новый PPslide и повторяйте весь процесс, пока не будет обработан весь лист. Я думаю, что это кажется относительно простым, но я все еще новичок и испытываю трудности с реализацией этого.

Будет ли это хорошей идеей и как мне туда добраться? Я довольно плохо разбираюсь в циклах, но я рад каждому ответу! Спасибо за ваше время и помощь!

PS: объявления для созданного PP и его объектов:

 Public Shape As Object
Public PPshape As PowerPoint.Shape
Public PPapp As PowerPoint.Application
Public PPpres As PowerPoint.Presentation
Public PPslide As PowerPoint.Slide
Public PPtextbox As PowerPoint.Shape

Set PPapp = New PowerPoint.Application
PPapp.Visible = msoTrue
 

Следующий код охватывает два сценария:

1. У вас открыт PowerPoint с активной презентацией, в начале которой есть слайд с заголовком и 5 текстовых полей с правильными именами

2. У вас закрыта PowerPoint

Вам нужно установить ссылку на объектную модель PowerPoint следующим образом:

Прочитайте комментарии к коду и попробуйте настроить его в соответствии с вашими потребностями

Используйте F8 клавишу для ввода кода построчно

Вы также можете добавить Stop оператор, чтобы код прерывался, а затем использовать клавишу F8

 Public Sub TransferDataToPPT()

    ' Set basic error handling
    On Error GoTo CleanFail

    ' Turn off stuff
    Application.ScreenUpdating = False
    
    Dim pptApp As PowerPoint.Application
    Dim pptPresentation As PowerPoint.Presentation
    Dim pptMainSlide As PowerPoint.Slide
    Dim pptContentSlide As PowerPoint.Slide
    
    Dim isNewPPTInstance As Boolean
   
    ' Open and get PowerPoint instance
    Set pptApp = OpenGetPowerPoint(isNewPPTInstance)
    
    ' If it's a new instance add new presentation and main slide
    If isNewPPTInstance Then
        pptApp.Visible = msoTrue
        Set pptPresentation = pptApp.Presentations.Add(msoTrue)
        Set pptMainSlide = pptPresentation.Slides.Add(1, ppLayoutTitleOnly)
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 150, 100, 20).Name = "Textbox1"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 200, 100, 20).Name = "Textbox2"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 250, 100, 20).Name = "Textbox3"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 300, 100, 20).Name = "Textbox4"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 350, 100, 20).Name = "Textbox5"
    Else
        Set pptPresentation = pptApp.ActivePresentation
        Set pptMainSlide = pptPresentation.Slides(1)
    End If
    
    ' Set a reference to the sheet holding the values
    Dim contentSheet As Worksheet
    Set contentSheet = ThisWorkbook.Worksheets("Sheet1")
    
    ' Set the Excel range to be evaluated
    Dim contentRange As Range
    Set contentRange = contentSheet.Range("A1:AO34")
    
    ' Start a cell counter
    Dim cellCounter As Long
    cellCounter = 1
    
    ' Loop through columns and cells
    Dim contentColumn As Range
    Dim contentCell As Range
    For Each contentColumn In contentRange.Columns
        For Each contentCell In contentColumn.Cells
            
            ' Skip after first blank cell
            If contentCell.Value = vbNullString Then Exit For
            
            ' Add new slide every 5 cells and fill title
            If cellCounter = 1 Then
                Set pptContentSlide = pptPresentation.Slides(1).Duplicate()(1)
                pptContentSlide.MoveTo pptPresentation.Slides.Count
                pptContentSlide.Shapes.Title.TextFrame.TextRange = contentSheet.Cells(35, contentColumn.Column).Value
            End If
            
            ' Add value to textbox
            pptContentSlide.Shapes("Textbox" amp; cellCounter).TextFrame.TextRange = contentCell.Value
            
            cellCounter = cellCounter   1
            
            ' Reset counter
            If cellCounter > 5 Then cellCounter = 1
            
        Next contentCell
    Next contentColumn
    

CleanExit:
    ' Turn on stuff again
    Application.ScreenUpdating = True
    
    If isNewPPTInstance Then
        If Not pptApp Is Nothing Then
            pptPresentation.SaveAs "C:TempNewPPT.pptx"
            pptApp.Quit
        End If
    End If
    Set pptApp = Nothing
    Exit Sub
    
CleanFail:
    MsgBox "An error occurred:" amp; Err.Description
    GoTo CleanExit
    
End Sub

Private Function OpenGetPowerPoint(ByRef isNewPPTInstance As Boolean) As PowerPoint.Application
    Dim pptApp As PowerPoint.Application
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
         'PPT wasn't running, start it from code:
        Set pptApp = CreateObject("PowerPoint.Application")
        isNewPPTInstance = True
    End If
    
    Set OpenGetPowerPoint = pptApp
    
End Function
 

Дайте мне знать, если это работает