Question

这是我第一次尝试在VBA中创建一些东西，所以请温柔。这就是我需要我的程序来做的事情：

从PPT运行并打开Excel文件
从幻灯片1开始，找到一个包含单词＆＃34; iq _＆＃34;的框，如果是的话有这些话然后就会有数字，就像这样＃34; iq_43＆＃34; 或＆＃34; iq_43，iq_56，iq_72＆＃34;。
在打开的Excel文件中找到这些单词和数字。需要认识到＆＃34;，＆＃34;意味着还有另一个条目。
复制包含来自ppt的单词的列。＆＃34; iq_43＆＃34;
使用这些值
为每张幻灯片执行此操作

我在底部遇到了我的功能问题。这是程序应该在打开的excel文件中转移的地方。这个想法是通过每列的标题并搜索我存储在＆＃34; iq_Array＆＃34;中的值。找到值后，将其下方的行复制到另一个名为＆＃34; tble＆＃34; （最终将作为表格粘贴到powerpoint幻灯片上。）

代码目前停在

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

毫无意义，因为之后您直接用{/ p>覆盖pptSlide

    For Each pptSlide In pptPres.Slides

<强> xlFindText

（2）

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

如果使用的是与运行代码的Office程序不同的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的逻辑 - 从此函数返回一个列号并在main函数中执行Copy + Paste，或者在xlFindText中执行这两个操作（然后传递{{ 1}}作为参数）。

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

1 个答案: