VBA循环遍历表

Question

I am trying to automate a very manual and annoying process.

The situation:I have a table in an excel worksheet, with source location for chart objects within the workbook, their target formatting specs, and their target location on a given powerpoint.

so far ive set up the code as follows. Ultimately i would like a loop to iterate over the entire cells of the table and pick up the necessary details to fulfill the below code. Ideally, replacing all italics with variables extracted from the table.

Please help!!

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

Make a procedure out of it using your desired variables as parameters:

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

Then you can use that procedure easily in a loop:

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

---

Edit (see comment)

I would add another parameter for the PPT file:

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

So you can open the PowerPoint in LoopThrougMyData and provide it as parameter to your procedure MyProcedure