Einfügen Position über mehrere Folien führt nicht durch, wird nur in der Mitte der Folie einfügen

Question

Ich habe ein wenig Mühe, die Tabellen, die aus Excel kopiert werden, irgendwo anders als die Mitte der PowerPoint eingefügt werden rutschen.

Ich muss die Spalten am Ende eine einheitliche Tabelle aussieht. Ich konnte nicht herausfinden, wie alle nicht zusammenhängenden Spalten in einer Tabelle aggregiert werden, daher füge ich jede Spalte einzeln hinzu und verschiebe jeden Eintrag um ein paar Ziffern.

Im Moment habe ich es, wo die Spalten auf der ersten Folie bei myShape.Left = 66 und myShape.Top = 152 eingefügt werden, aber nach der ersten Folie gehen sie einfach wieder in die Mitte der Folie einfügen.

Irgendwelche Ideen?

Public Sub averageScoreRelay() 
    ' 1. Run from PPT and open an Excel file 
    ' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56, iq_72". 
    ' 3. find those words and numbers in the opened Excel file. Needs to recognize that ", " means there is another entry. 
    ' 3. Copy column containing words from ppt ie. "iq_43" 
    ' 4. Paste a Table into ppt with those values 
    ' 5. Do this for every slide 

    'Create variables 
    Dim xlApp As Excel.Application 
    Dim xlWB As Excel.Workbook 
    Dim pptSlide As Slide 
    Dim fileName As String 
    Dim Shpe As Shape 
    Dim pptText As String 
    Dim strArray As String 
    Dim pptPres As Object 
    Dim PowerPointApp As Object 
    Dim iq_Array 
    Dim arrayLoop As Integer 
    Dim i As Integer 
    Dim myShape As Object 

    ' Create new excel instance and open relevant workbook 
    Set xlApp = New Excel.Application 
    Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook 
    If xlWB Is Nothing Then ' may not need this if statement. check later. 
     MsgBox ("Error retrieving Average Score Report, Check file path") 
     Exit Sub 
    End If 

    'Is PowerPoint already opened? 
    'Set PowerPointApp = GetObject(class:="PowerPoint.Application") 

    'Make PPT visible 
    Set pptPres = PowerPoint.ActivePresentation 

    'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable 
    For Each pptSlide In pptPres.Slides 
     'searches through shapes in the slide 
     For Each Shpe In pptSlide.Shapes 
      'Identify if there is text frame 
      If Shpe.HasTextFrame Then 
       'Identify if there's text in text frame 
       If Shpe.TextFrame.HasText Then 
        pptText = Shpe.TextFrame.TextRange 
        If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now 
         iq_Array = Split(pptText, ", ")    'Use function below to Set iq_Array to an array of all iq_'s in the text box 
         size = UBound(iq_Array) - LBound(iq_Array) 
         For arrayLoop = 0 To size 
          For i = 1 To 5 
           If i = 1 And arrayLoop = 0 Then 
            xlWB.Worksheets("Sheet1").Columns(1).Copy 
            pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse 
            Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count) 
            'Set position: 
            myShape.Left = 66 
            myShape.Top = 152 
           ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then 
            xlWB.Worksheets("Sheet1").Columns(i).Copy 
            pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse 
            Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count) 
            'Set position: 
            myShape.Left = 66 
            myShape.Top = 152 
           End If 
          Next i 
         Next arrayLoop 
        End If 
       End If 
      End If 
     Next Shpe 
    Next pptSlide 
End Sub 

Answer 1

Ich konnte alles zusammenfassen, indem ich ein neues Blatt erstellte und jede Spalte einzeln auf dieses Blatt kopierte und dieses dann in PowerPoint kopierte.

Auch, um es einfügen, wo ich es auf der Folie will, habe ich darauf geachtet, VBA .Select alles zu machen.

With xlWB.Worksheets("Sheet1") 
    colNumb = .Cells(1, .Columns.Count).End(xlToLeft).Column 
End With 

xlWB.Worksheets.Add After:=xlWB.ActiveSheet 

'Make pptPres the ppt active 
Set pptPres = PowerPoint.ActivePresentation 

'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable 
For Each pptSlide In pptPres.Slides 
    'searches through shapes in the slide 
    pptSlide.Select 
    For Each Shpe In pptSlide.Shapes 
     'Identify if there is text frame 
     k = 1 
     If Shpe.HasTextFrame Then 
      'Identify if there's text in text frame 
      If Shpe.TextFrame.HasText Then 
       pptText = Shpe.TextFrame.TextRange 
       If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now 
        iq_Array = Split(pptText, ", ")    'set iq_Array as an array of the split iq's 
        size = UBound(iq_Array) - LBound(iq_Array) 
        For arrayLoop = 0 To size 'loop for each iq_array 
         For i = 1 To colNumb 'loops for checking each column 
          If i = 1 And arrayLoop = 0 Then 'Copies the first column for every slide 
           If Len(iq_Array(arrayLoop)) < 4 Then GoTo Line2 
           xlWB.Worksheets("Sheet1").Columns(1).Copy 'copy column 
           xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1) 
          ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then 'if iq in ppt = iq in xl and if not the first cell then execute 
           k = k + 1 
           xlWB.Worksheets("Sheet1").Columns(i).Copy 
           xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k) 
          End If 
         Next i 
Line2: 
        Next arrayLoop 
       End If 
      End If 
     End If 
    Next Shpe 
'calculate last row and last column 
With xlWB.Worksheets("Sheet2") 
    lRows = .Cells(.Rows.Count, 1).End(xlUp).Row 
    lCols = .Cells(1, .Columns.Count).End(xlToLeft).Column 
    If lRows = .Cells(1, 1).End(xlUp).Row And lCols = .Cells(1, 1).End(xlToLeft).Column Then 
     GoTo Line1 
    End If 
     .Range(.Cells(1, 1), .Cells(lRows, lCols)).Copy 
End With 
     pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse 
     Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count) 
     'Set position: 
     myShape.Left = -200 
     myShape.Top = 200 
     xlWB.Worksheets("Sheet2").Range("A1:P10").Clear 
Line1: 
Next pptSlide 

xlWB.Worksheets("Sheet2").Delete 

End Sub