CODEWITHSUNDEEP
arraysexcelvbarangepowerpoint
Luis Cáceres
Luis Cáceres

Reputation: 51

vba powerpoint populating an array from excel range

I´m trying to set a array with data from a MS Excel range. My VBA Macro replaces the text from an array with text from another array. It works fine with arrays, but now I´m trying to fill these arrays with data from a Excel file. I´m using range and I´ve tried thousands of ways of making itwork, unsuccessfuly. I´m not a VBA coder, so maybe I´m missing some basic concepts.... :|

Heres the code. Thanks in advance for any help!

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

Upvotes: 1

Views: 1380

Answers (2)

brettdj
brettdj

Reputation: 55682

You can speed up your code significantly by:

  1. Looping through a variant array rather than a range
  2. Splitting your IF test into two parts (VBA doesn't shortcircuit so will evaluate both parts of an AND even if the first part is False).

code

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

Upvotes: 1

Luis Cáceres
Luis Cáceres

Reputation: 51

Finaly I found a solution: stop using Array and swith to Dictionary. Here the code wich worked:

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

Moral of the history: use the right datatype for the job ;)

Upvotes: 1

Related Questions