Problem with find method and changing text boxes dimesion

Hi everyone,

I’m working on the macro the aim of which is to search for certain words (Note; Source) within the text boxes. In other words, the macro should change the dimension of text boxes containing these particular words in the following way:

.Width = 773
.Height = 24
.Left = 15
.Top = 520

I have already created the macro but I noticed it crashes VBA and the entire PowerPoint every time I run it. As a result, I cannot even find out whether the code is properly written.

Do you have any ideas how to fix this problem or how to modify the code, so that it does not harm PowerPoint?

The code is as follows:

Code:

---

Sub NoteandSource()
    Dim oSld As Slide
    Dim oShp As Shape
    Dim TR As TextRange
    Dim TRFind1 As TextRange
    Dim TRFind2 As TextRange
 
 For Each oSld In ActivePresentation.Slides
        For Each oShp In oSld.Shapes
            If oShp.HasTextFrame Then
                If oShp.TextFrame.HasText Then
                    Set TR = oShp.TextFrame.TextRange
                    Set TRFind1 = TR.Find(FindWhat:="Note")
                    Set TRFind2 = TR.Find(FindWhat:="Source")
 
                  Do While Not (TRFind1 Is Nothing)
Do While Not (TRFind2 Is Nothing)

                            With oShp
              .Width = 773
              .Height = 24
              .Left = 15
              .Top = 520
              End With
 
              Loop
              Loop
 
          End If
      End If
    Next
Next

End Sub

---

It's not exactly "harming" PowerPoint, your code will go into an endless loop. You need to start the search in the loop after the point it was last found.

I would also do the two searches separately.

Code:

---

Sub NoteandSource()
Dim oSld As Slide
Dim oShp As Shape
Dim TR As TextRange
Dim TRFind1 As TextRange
Dim TRFind2 As TextRange


For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then


Set TR = oShp.TextFrame.TextRange
Set TRFind1 = TR.Find(FindWhat:="Note", WholeWords:=True)
Do While Not (TRFind1 Is Nothing)
Set TRFind1 = TR.Find(FindWhat:="Note", After:=TRFind1.Start + TRFind1.Length, WholeWords:=True)
With oShp
.Width = 773
.Height = 24
.Left = 15
.Top = 520
End With
Loop
Set TRFind2 = TR.Find(FindWhat:="Source", WholeWords:=True)
Do While Not (TRFind2 Is Nothing)
Set TRFind2 = TR.Find(FindWhat:="Source", After:=TRFind2.Start + TRFind2.Length, WholeWords:=True)
With oShp
.Width = 773
.Height = 24
.Left = 15
.Top = 520
End With
Loop
End If
End If
Next
Next
End Sub

---

It works just perfectly, thank you for your help John!