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
|