Loop-Testing

The Challenge

In his Finding and Replacing in Text Boxes tip, Allen provides code to do a find-and-replace of character strings in Shapes on a worksheet.  One of the readers, Curt, was having trouble replacing 2 consecutive spaces with singles.  

Possible Cause

My thought was the problem may not be it is not working but the condition is such it seems like it is not.  This would happen if there were more than 3 or more consecutive spaces.  Therefore I recommended adding Do Until ... Loop.

Original code

    For Each shp In ActiveSheet.Shapes
            With shp.TextFrame.Characters
                .Text = Application.WorksheetFunction.Substitute(.Text, sOld, sNew)
            End With
    Next

Suggestion

The code below has one small change that allows the code to pass through again, and more if necessary, if for some reason the first pass caused the condition to re-arise or didn't clear it completely the first time.

    For Each shp In ActiveSheet.Shapes

            With shp.TextFrame.Characters
                Do Until Instr(1,.Text,sOld) = 0
                    .Text = Application.WorksheetFunction.Substitute(.Text, sOld, sNew)
                Loop
            End With
    Next

Follow-up

Thinking about this more it seems there are a few more things that could be done differently.

Instead of adding the Do Until...Loop for this case, one could also have a Sub that uses Application.WorksheetFunction.Trim(.Text).  This will rid the string of extra spaces.  It will also get rid of leading and trailing spaces.  

Something else that might be done would be to flag the changed shapes with different fill or font colors