从Excel范围填充数组

我试图设置一个数组从MS Excel范围的数据。 我的VBAmacros用另一个数组中的文本replace数组中的文本。 它适用于数组，但现在我试图用Excel文件中的数据填充这些数组。 我正在使用范围，我尝试了成千上万的方法，不成功。 我不是一个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

最后，我find了一个解决scheme：停止使用数组，并切换到词典。 这里代码工作：

 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 

历史的道德：使用正确的数据types的工作;）

Answer 2

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

1. 通过variables数组而不是范围循环
2. 将你的IFtesting分成两部分（VBA不会短路，所以即使第一部分是假的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