在PPT中查找形状，然后在文本中search该文本，复制列，然后将其粘贴回PPT作为表格

这是我第一次真正尝试在VBA中创造一些东西，所以请温和。 这是我需要我的程序做的事情：

1. 从PPT运行并打开一个Excel文件
2. 从幻灯片1开始，find一个包含单词“iq_”的框，如果它包含这些单词，那么它就会有像“iq_43”或“iq_43，iq_56，iq_72”那样的数字。
3. 在打开的Excel文件中find这些单词和数字。 需要认识到“，”意味着有另一个条目。
4. 复制包含来自ppt的单词的列即。 “iq_43”
5. 将这些值粘贴到ppt中
6. 为每张幻灯片做这个

我的底部function有问题。 这是程序应该转移到打开的Excel文件中工作的地方。 这个想法是通过每列的标题，并search“iq_Array”中存储的值。 一旦find值，然后将其下面的行复制到另一个名为“tble”的数组（最终将作为表格粘贴到幻灯片上）。

代码现在停在

rng = Worksheets("Sheet1").Cells(1, i).Value 

我不确定我在这里做错了什么。 一旦修复，这将是能够被复制到一个数组？

另一个我相信我遇到麻烦的部分是如何返回函数值。 我现在有

 xlFindText(iq_Array, xlWB) = tble() 

在我的函数底部，以便在我的主代码中调用它。 这是正确的方法吗？

 Public Sub averageScoreRelay() '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 ' Create new excel instance and open relevant workbook Set xlApp = New Excel.Application xlApp.Visible = True 'Make Excel visible 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 Set pptSlide = Application.ActiveWindow.View.Slide 'Set pptSlide = pptPres.Slides _ (PowerPointApp.ActiveWindow.Selection.SlideRange.SlideIndex) (different way of saying the same thing?) '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 xlFindText(iq_Array, xlWB).Copy pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse ' Paste the Array End If End If End If Next Shpe Next pptSlide End Sub Function xlFindText(iq_Array, xlWB) 'This function works in excel and saves the column values into xlFindText(iq_Array, xlWB) to be pasted as a table into ppt 'SetsxlTextID = to the array of iq_'s Dim i As Integer Dim k As Integer Dim activeWB As Excel.Workbook Dim size As String Dim rng As Range Dim tble As Range 'for loop to go through values stored in array size = UBound(iq_Array) - LBound(iq_Array) For i = 0 To size 'loops through array values For k = 1 To 200 'loops through cloumns rng = Worksheets("Sheet1").Cells(1, i).Value If rng = iq_Array(i) Then 'matches column value to iq_Array Columns(k).Select tble(i) = Selection.Copy 'saves a copy of the range into tble() array End If Next k Next i xlFindText(iq_Array, xlWB) = tble() End Function 

Answer 1

你的代码有几个问题，我会从头到尾，但很可能是我错过了一些。

（1）

 Set pptSlide = Application.ActiveWindow.View.Slide 

是毫无意义的，因为之后你用pptSlide覆盖pptSlide ：

  For Each pptSlide In pptPres.Slides 

xlFindText

（2）

 rng = Worksheets("Sheet1").Cells(1, i).Value 

如果您使用的是不同于运行代码的Office程序（此处为PPT中的Excel），则始终必须完全限定您的对象。 不要使用像ActiveSheet这样的快捷方式而不指定父对象（Excel应用程序）。

所以这应该是：

 xlWB.Worksheets("Sheet1").Cells(1, i).Value 

Columns(k) 。

（3）

rng是一个Range对象。 这不与单元格值一起使用。

或

 Set rng = xlWB.Worksheets("Sheet1").Cells(1, i) 

要么

 Dim varValue As Variant varValue = xlWB.Worksheets("Sheet1").Cells(1, i).Value 

（4）

 tble(i) = Selection.Copy 

这不是Range.Copy工作方式，请查看Excel在线帮助。

你将不得不改变xlFindText的逻辑 – 或者从这个函数返回一个列号，然后在主函数中执行复制+粘贴，或者在xlFindText执行这两个xlFindText （然后传递pptSlide作为参数）。