vba powerpoint 从 excel 范围填充数组

Question

我正在尝试使用 MS Excel 范围内的数据设置一个数组。 我的 VBA 宏将一个数组中的文本替换为另一个数组中的文本。 它适用于数组，但现在我试图用 Excel 文件中的数据填充这些数组。 我正在使用 range 并且我已经尝试了数千种使其工作的方法，但没有成功。 我不是 VBA 编码员，所以也许我缺少一些基本概念....:|

这是代码。 在此先感谢您的帮助！

Sub ReplacePT2ES()

    Dim oSld As Slide
    Dim oShp As Shape
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim strWhatReplace As String, strReplaceText As String
    Dim x As Long


    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim rng As range


    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open("D:\DOCS\DiccionarioPT2ES.xlsx")
    xlBook.Application.Visible = False
    xlBook.Application.WindowState = xlMinimized


    Dim findList As Variant
    Dim replaceList As Variant

    Set findList = range("A1:A3").Value

    Set replaceList = range("B1:B3").Value
    '-- works fine with array
    'findList = Array("falha", "lei", "projeto", "falhas", "leis", "projetos", "falham", "os", "as", "gestor")
    'replaceList = Array("falla", "ley", "proyecto", "fallas", "leyes", "proyectos", "fallan", "los", "las", "gerente")

    'MsgBox "Iniciando!"

    For x = findList.Count To replaceList.Count
        ' go during each slides
        For Each oSld In ActivePresentation.Slides
             ' go during each shapes and textRanges
            For Each oShp In oSld.Shapes
                 ' replace in TextFrame
                'If oShp.HasTextFrame And UBound(findList) And UBound(replaceList) > 0 Then
                 If oShp.HasTextFrame Then

                    Set oTxtRng = oShp.TextFrame.TextRange
                    Set oTmpRng = oTxtRng.Replace(FindWhat:=findList(x), Replacewhat:=replaceList(x), WholeWords:=True)

                    Do While Not oTmpRng Is Nothing

                        Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                        Set oTmpRng = oTxtRng.Replace(FindWhat:=findList(x), Replacewhat:=replaceList(x), WholeWords:=True)
                    Loop
                 End If
            Next oShp
        Next oSld
    Next x

 xlBook.Close SaveChanges:=False
 Set xlApp = Nothing
 Set xlBook = Nothing
 'MsgBox "Listo!"


End Sub

Answer 1

最后我找到了一个解决方案：停止使用数组并切换到字典。 这里的代码有效：

Set findList = range("A1:A10")
Dim MyDictionary As Object
Set MyDictionary = CreateObject("Scripting.Dictionary")

With MyDictionary
    For Each RefElem In findList
        If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
            .Add RefElem.Value, RefElem.Offset(0, 1).Value
        End If
    Next RefElem
End With

历史的寓意：为工作使用正确的数据类型；)

Answer 2

您可以通过以下方式显着加快代码速度：

1. 循环遍历变体数组而不是范围
2. 将您的 IF 测试分成两部分（VBA 不会短路，因此即使第一部分为 False 也会评估AND两个部分）。

代码

Sub Recut()
Dim X
Dim MyDictionary As Object
Dim lngRow As Long
Set MyDictionary = CreateObject("Scripting.Dictionary")

X = Range("A1:B10").Value2
With MyDictionary
For lngRow = 1 To UBound(X)
    If Len(X(lngRow, 1)) > 0 Then
        If Not .Exists(X(lngRow, 1)) Then .Add X(lngRow, 1), X(lngRow, 2)
    End If
Next
End With
End Sub