循环遍历现有工作表中的列 - 将值作为文本框粘贴到现有 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 幻灯片上为每个文本框设置位置？每个 PowerPointslide 的幻灯片标题已经保存在工作表中每列的第 35 行（见屏幕截图），所以我也会把它交给循环内的 PP（对于每列设置 slidetitle = currentColumn.Row 35 有点想法）

我目前的想法是每张幻灯片有 5 个文本框并设置位置，用第一列第 1-5 行的值填充它们，然后创建一张新幻灯片并对第 6-行执行相同的过程10以此类推，直到当前列中的Cell.Value为空，然后向右跳一列并再次创建一个新的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

Answer 1

以下代码涵盖两种场景：

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

1. 您已关闭 PowerPoint

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

---

阅读代码的 cmets 并尝试调整它以满足您的需求

使用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

让我知道它是否有效