Option Explicit 
Sub xlRemoveExtra() 
     '
     '****************************************************************************************
     '       Function:   demonstrates the RemoveExtra function for Excel
     '****************************************************************************************
     '
     '
    Dim Char        As String 
    Dim MsgBxRtn    As VbMsgBoxResult 
    Dim MsgBxTitle  As String 
    Dim Num         As Long 
    Dim strNum      As String 
    Dim strText     As String 
     
    MsgBxTitle = "xlRemoveExtra" 
GetChar: 
    Char = InputBox("test or target character?", MsgBxTitle) 
    If Char = "" Then Exit Sub 
GetNum: 
    strNum = InputBox("# of test chars allowed?", MsgBxTitle) 
    Select Case strNum 
    Case vbNullString, "" 
        GoTo GetChar 
    Case Is < 0 
        MsgBox "# must be >= 0", vbCritical + vbOKOnly 
        GoTo GetNum 
    Case Is = 0 
        MsgBxRtn = MsgBox("a zero value will effectively remove all" & vbCrLf & _ 
        "instances of the target character.   OK?", _ 
        vbQuestion + vbYesNoCancel, MsgBxTitle) 
        If MsgBxRtn <> vbYes Then GoTo GetNum 
        Num = strNum 
    Case Else 
        Num = strNum 
    End Select 
     
    strText = Cells(2, 2).Text 
    Cells(4, 2) = RemoveExtra(strText, Char, Num) 
     
End Sub 
 
Function RemoveExtra(strText As String, _ 
    Optional Char As String = " ", _ 
    Optional Num As Long = 1) As String 
     '
     '****************************************************************************************
     '       Function    removes extra repeated characters from a target string.  The revised
     '                   string is returned as the functional value.
     '       Passed Values:
     '           strText  [in, string]  target string to be examined
     '           Char     [in, string, OPTIONAL]  target character {default = " "}
     '           Num      [in, long, OPTIONAL] number of allowable repetitions {default = 1}
     '
     '   NOTES:  let strOld = "now is the  time for all good men to come to the aid of their party"
     '
     '           note the two blank between "the" and "time"
     '
     '           we set strNew = RemoveExtra(strOld, " ", 1)    then
     '           strNew is now = "now is the time for all good men to come to the aid of their party"
     '****************************************************************************************
     '
     '
    Dim OrigLen As Long 
     '
     '           ensure acceptable value for Num
     '
    If Num < 0 Then 
        MsgBox "RemoveExtra: value for Num is not valid", "vbCritical + vbOKOnly" 
        Exit Function 
    End If 
     '
     '           copy original text string into RemoveExtra
     
     '           keep calling Replace with repeated (target) char string of length Num+1
     '               replaced by similar string of length Num until result does not change
     '
    RemoveExtra = strText 
    Do Until Len(RemoveExtra) = OrigLen 
        OrigLen = Len(RemoveExtra) 
        RemoveExtra = Replace(RemoveExtra, String(Num + 1, Char), String(Num, Char)) 
    Loop 
     
End Function 
 '
 ' ************************************************************
 '     WORD code
 ' ************************************************************
Sub wrdRemoveExtra() 
     '
     '****************************************************************************************
     '       Function:   demonstrates the RemoveExtra function for Word
     '****************************************************************************************
     '
     '
    Dim Char        As String 
    Dim MsgBxRtn    As VbMsgBoxResult 
    Dim MsgBxTitle  As String 
    Dim Num         As Long 
    Dim strNum      As String 
    Dim strText     As String 
     
    MsgBxTitle = "xlRemoveExtra" 
GetChar: 
    Char = InputBox("test or target character?", MsgBxTitle) 
    If Char = "" Then Exit Sub 
GetNum: 
    strNum = InputBox("# of test chars allowed?", MsgBxTitle) 
    Select Case strNum 
    Case vbNullString, "" 
        GoTo GetChar 
    Case Is < 0 
        MsgBox "# must be >= 0", vbCritical + vbOKOnly 
        GoTo GetNum 
    Case Is = 0 
        MsgBxRtn = MsgBox("a zero value will effectively remove all" & vbCrLf & _ 
        "instances of the target character.   OK?", _ 
        vbQuestion + vbYesNoCancel, MsgBxTitle) 
        If MsgBxRtn <> vbYes Then GoTo GetNum 
        Num = strNum 
    Case Else 
        Num = strNum 
    End Select 
     
    strText = Selection.Text 
    Selection.Text = RemoveExtra(strText, Char, Num) 
     
End Sub 
 
Function RemoveExtra(strText As String, _ 
    Optional Char As String = " ", _ 
    Optional Num As Long = 1) As String 
     '
     '****************************************************************************************
     '       Function    removes extra repeated characters from a target string.  The revised
     '                   string is returned as the functional value.
     '       Passed Values:
     '           strText  [in, string]  target string to be examined
     '           Char     [in, string, OPTIONAL]  target character {default = " "}
     '           Num      [in, long, OPTIONAL] number of allowable repetitions {default = 1}
     '
     '   NOTES:  let strOld = "now is the  time for all good men to come to the aid of their party"
     '
     '           note the two blank between "the" and "time"
     '
     '           we set strNew = RemoveExtra(strOld, " ", 1)    then
     '           strNew is now = "now is the time for all good men to come to the aid of their party"
     '****************************************************************************************
     '
     '
    Dim OrigLen As Long 
     '
     '           ensure acceptable value for Num
     '
    If Num < 0 Then 
        MsgBox "RemoveExtra: value for Num is not valid", "vbCritical + vbOKOnly" 
        Exit Function 
    End If 
     '
     '           copy original text string into RemoveExtra
     '           keep calling Replace with repeated (target) char string of length Num+1
     '               replaced by similar string of length Num until result does not change
     '
    RemoveExtra = strText 
    Do Until Len(RemoveExtra) = OrigLen 
        OrigLen = Len(RemoveExtra) 
        RemoveExtra = Replace(RemoveExtra, String(Num + 1, Char), String(Num, Char)) 
    Loop 
     
End Function