我在将从Excel复制的表格粘贴到PowerPoint幻灯片中间以外的任何其他位置时遇到了一些麻烦。
我需要让列最终看起来是一个统一的表。我无法弄清楚如何将所有非连续列聚合到一个表中，因此我将逐个粘贴每个列并将每个条目移动几个数字。
现在我可以将第一张幻灯片上的列粘贴到myShape.Left = 66和myShape.Top = 152，但是在第一张幻灯片后，它们会回到幻灯片中间粘贴。
有什么想法吗？
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
答案 0 :(得分：0)
我能够通过创建新工作表并将每个列单独粘贴到该工作表上然后将其复制到PowerPoint中来聚合所有内容。
另外，为了让它在幻灯片上粘贴我想要的地方，我确保让VBA .Select一切。
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