ReDim Preserve Powerpoint VBA

[jsotor4]

I have the following code which what it does it searches the presentation for a specific word. In this case "Scott" and it returns each slide that has that word on it. I do not have much knowledge of VBA so any help would be appreciated. Basically my problem is I need to Redim Preserve the step array to reduce the amount of elements it has. Below is the code, function and output.

Sub Email()
Dim sld As Slide
Dim shp As Shape
Dim txtRng As TextRange
Dim foundText As TextRange
Dim slidecount As Integer
Dim step() As Variant
slidecount = ActivePresentation.Slides.Count
With ActivePresentation
a = "Scott: Component Status, Effective Dates Slides:"
Debug.Print a
ReDim step(slidecount)
For i = 1 To slidecount
   For Each shp In ActivePresentation.Slides(i).Shapes
       If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(FindWhat:="SCOTT")
            Do While Not (foundText Is Nothing)
                With foundText
                  
                    step(i) = ActivePresentation.Slides(i).SlideNumber
                    
                    Exit For
                End With
            Loop
        End If
    Next
Next
Call FilterDuplicates(step)
joinarray = Join(step, ",")
Debug.Print joinarray
End With
End Sub

And here is the function that is calls.

Function FilterDuplicates(step As Variant) As Long
    Dim col As Collection, index As Long, dups As Long
    Set col = New Collection
    On Error Resume Next
    Dim a() As String
    For index = LBound(step) To UBound(step)
        ' build the key using the array element
        ' an error occurs if the key already exists
        col.Add 0, CStr(step(index))
        If Err Then
            ' we've found a duplicate
            step(index) = Empty
            dups = dups + 1
            Err.Clear
        ElseIf dups Then
            ' if we've found one or more duplicates so far
            ' we need to move elements towards lower indices
            step(index - dups) = step(index)
            step(index) = Empty
        End If
    Next
    
    
    dups = FilterDuplicates(a())
     If dups Then
         ReDim Preserve a(LBound(a) To (UBound(a) - dups))
     End If
     
End Function

This is the output that I get hen i run this code.


Scott: ,4,5,8,14,17,20,23,35,37,39,45,47,50,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,


Basically I want to ReDim Preserve the array to the proper size but It doesnt seem to work in the function where I have written it.

[John Wilson]

Not sure you really need an array at all

It might look like this though:

Sub findWord()
Const FINDTHIS As String = "Whatever"
Dim i      As Integer
Dim osld   As Slide
Dim oshp   As Shape
Dim raySlides() As Long
Dim strResult As String
Dim foundText As TextRange
Dim txRange As TextRange
ReDim raySlides(1 To 1)
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set txRange = oshp.TextFrame.TextRange
Set foundText = txRange.Find(FindWhat:=FINDTHIS)
Do While Not (foundText Is Nothing)
With foundText
raySlides(UBound(raySlides)) = osld.SlideIndex
ReDim Preserve raySlides(1 To UBound(raySlides) + 1)
Exit For
End With
Loop
End If
End If
Next oshp
Next osld
If UBound(raySlides) > 1 Then
For i = 1 To UBound(raySlides) - 1
If i < UBound(raySlides) - 1 Then
strResult = strResult & CStr(raySlides(i)) & "/"
Else
strResult = strResult & CStr(raySlides(i))
End If
Next i
End If
MsgBox strResult
End Sub

It might be simpler to do this:

Sub findWord2()
Const FINDTHIS As String = "Whatever"
Dim i      As Integer
Dim osld   As Slide
Dim oshp   As Shape
Dim strResult As String
Dim foundText As TextRange
Dim txRange As TextRange
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set txRange = oshp.TextFrame.TextRange
Set foundText = txRange.Find(FindWhat:=FINDTHIS)
Do While Not (foundText Is Nothing)
With foundText
strResult = strResult & CStr(osld.SlideIndex) & "/"
Exit For
End With
Loop
End If
End If
Next oshp
Next osld
If strResult <> "" Then strResult = Left(strResult, Len(strResult) - 1)
MsgBox strResult
End Sub

Both might need a little work

[jsotor4]

Works Perfectly. Thanks so much!