遍历现有工作表中的列 - 将值作为文本框粘贴到现有 PowerPoint

Question

我制作了一个 VBA 宏，它可以自动创建一个 PowerPoint 和一个创建名为“Handlungsempfehlungen”的带有文本的工作表。工作表“Handlungsempfehlungen”如下所示：

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

它大约有 40 列 (A-AO)，每列中的文本从第 1 行到最大行。 34（每列填充文本的行数各不相同）。我现在需要以某种方式遍历每一列中的每一行，并将每个 Cell.Value 交给现有（和当前打开的）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 幻灯片上的位置？每个 PowerPoint 幻灯片的幻灯片标题已经保存在工作表中每个列的第 35 行（见屏幕截图），所以我也会将其交给循环内的 PP（对于每个列设置 slidetitle = currentColumn.Row 35 是有点想法）

我目前的想法是每张幻灯片有 5 个文本框并设置位置，用第一列第 1-5 行的值填充它们，然后创建一张新幻灯片并对行执行相同的过程6-10 依此类推，直到当前列中的Cell.Value为空，然后向右跳一列，重新新建一个PPslide，重复整个过程，直到整个Worksheet 都处理完。我觉得这看起来比较简单，但我还是个初学者，很难实现。

这是个好主意吗？我需要如何到达那里？我很不擅长循环，但我很高兴得到每一个答案！感谢您的宝贵时间和帮助！

PS：创建的PP及其Objects的声明：

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

Answer 1

以下代码涵盖两种场景：

您打开的 PowerPoint 中有一个活动演示文稿，该演示文稿开头有一张幻灯片，标题和 5 个正确命名的文本框

您已关闭 PowerPoint

您需要像这样设置对 PowerPoint object 模型的引用：

阅读代码注释并尝试调整它以满足您的需要

使用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" & 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:\Temp\NewPPT.pptx"
            pptApp.Quit
        End If
    End If
    Set pptApp = Nothing
    Exit Sub
    
CleanFail:
    MsgBox "An error occurred:" & 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

如果有效请告诉我

遍历现有工作表中的列 - 将值作为文本框粘贴到现有 PowerPoint

Loop Through Columns in Existing Worksheet - Paste Values to Existing PowerPoint as Textboxes

excel

powerpoint

vba

loops

paste