在PPT中查找形狀，然後在文本中搜索該文本，複製列然後將其粘貼回PPT中作爲表格

Question

這是我第一次真正嘗試在VBA中創建某些內容，因此請溫和請。 這是我需要我的程序來做：

1. 從PPT運行並打開一個Excel文件
2. 開始在幻燈片1，並找到一個包含詞語「iq_」一箱，如果 有那些話那麼它就會有數字，例如「iq_43」 或「iq_43，iq_56，iq_72」。
3. 在打開的Excel文件中找到這些單詞和數字。需要 認識到「，」意味着有另一個條目。
4. 複製包含ppt即單詞的列。 「iq_43」
5. 一個表粘貼到PPT使用這些值
6. 這樣做對我和我的底部函數問題的每張幻燈片

。這是程序應該轉移到打開的excel文件中工作的地方。想法是通過每列的標題並搜索我已經存儲在「iq_Array」中的值。一旦找到值，然後將它下面的行復制到另一個名爲「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

你的代碼有幾個問題，我會從頭到尾去做，但很可能是我錯過了一些。

For Each pptSlide In pptPres.Slides 

xlFindText

（2）

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

0：

（1）

Set pptSlide = Application.ActiveWindow.View.Slide 

因爲直接事後您覆蓋pptSlide與是無意義

如果您使用的是不同於運行代碼的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兩者都做（再經過pptSlide作爲參數）。