在表上迭代VBA循环

Question

我试图自动化一个非常手动和烦人的过程。

情况:我在excel工作表中有一个表，其中包含工作簿中图表对象的源位置、它们的目标格式规范以及它们在给定powerpoint上的目标位置。

到目前为止，我已经设置了如下代码。最后，我想要一个循环来遍历整个表格单元，并获取必要的细节来完成下面的代码。理想情况下，用从表中提取的变量替换所有斜体。

救命啊！！

Dim shP As Object
Dim myShape As Object
Dim mySlide As Object
Dim tempSize As Integer, tempFont As String

Worksheets("Sheet 1").Activate

'select the name of report
Set shP = Range(V.Title)

'select the ppt sheet you wish to copy the object to
Set mySlide = PPT.ActivePresentation.slides(1)

'count the number of shapes currently on the PPT
shapeCount = mySlide.Shapes.Count
'copy the previously selected shape
shP.Copy
'paste it on the PPT
mySlide.Shapes.Paste

'wait until the count of shapes on the PPT increases, which signals that the past operation is finished.
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount

'adjust formatting of the newly copied shape: position on the sheet, font & size
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    myShape.Left = 254.016
    myShape.Top = 42.8085
    myShape.Width = 286.0515
    myShape.Height = 46.7775
    myShape.TextEffect.FontSize = 15
    myShape.TextEffect.FontName = "Century Schoolbook"

Answer 1

使用所需的变量作为参数，从中生成一个过程：

Sub MyProcedure(RangeTitle As String, SlideNumber As Long, SetLeft As Double, SetTop As Double, SetWidth As Double, SetHeight As Double)
    Dim shP As Object
    Dim myShape As Object
    Dim mySlide As Object
    Dim tempSize As Integer, tempFont As String

    Dim ws As Worksheet
    Set ws = Worksheets("Sheet 1")

    'select the name of report
    Set shP = ws.Range(RangeTitle)

    'select the ppt sheet you wish to copy the object to
    Set mySlide = PPT.ActivePresentation.slides(SlideNumber)

    'count the number of shapes currently on the PPT
    shapeCount = mySlide.Shapes.Count
    'copy the previously selected shape
    shP.Copy
    'paste it on the PPT
    mySlide.Shapes.Paste

    'wait until the count of shapes on the PPT increases, which signals that the past operation is finished.
    Do '<~~ wait completion of paste operation
        DoEvents
    Loop Until mySlide.Shapes.Count > shapeCount

    'adjust formatting of the newly copied shape: position on the sheet, font & size
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = SetLeft
        .Top = SetTop
        .Width = SetWidth
        .height = SetHeight
        .TextEffect.FontSize = 15
        .TextEffect.FontName = "Century Schoolbook"
    End With
End Sub

然后，您可以在循环中轻松地使用该过程：

Sub LoopThrougMyData()

    Dim iRow As Long
    For iRow = FirstRow To LastRow 'loop through your table here

        With Worksheets("YourDataTable")
            MyProcedure RangeTitle:=.Cells(iRow, "A"), SlideNumber:=.Cells(iRow, "B"), SetLeft:=.Cells(iRow, "C"), SetTop:=.Cells(iRow, "D"), SetWidth:=.Cells(iRow, "E"), SetHeight:=.Cells(iRow, "F")
            'call the procedure with the data from your table
        End With

    Next iRow

End Sub

编辑(见注释)

我将为PPT文件添加另一个参数：

Sub MyProcedure(PPT As Object, RangeTitle As String, SlideNumber As Long, …

因此，您可以在PowerPoint中打开LoopThrougMyData并将其作为参数提供给您的过程MyProcedure。