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!