VBA code to remove characters

[zaska]

Hello,

Can anyone help me with a vba code to remove characters from selection

1. Remove Numeric characters
2. Remove Alphabetic characters
3. Remove Non-Numeric characters
4. Remove Non Alphabetic characters
5. Remove Non Alpha-Numeric characters
6. Remove Unprintable characters

Thanks

Zaska

 

[zaska]

Can anyone help me?

Thanks

 

[Rick Rothstein]

Use this structure for each case, just change the line highlighted code lines in red and blue to the indicated code statements shown in the write-up following the code...

Sub ReplaceThings()
  Dim X As Long, Y As Long, Z As Long, Arr As Variant
  Arr = Selection.Value
  For X = LBound(Arr) To UBound(Arr)
    For Y = LBound(Arr, 2) To UBound(Arr, 2)
      For Z = 1 To Len(Arr(X, Y))
        [COLOR=red][B]<<< see write-up >>>[/B][/COLOR]
[COLOR=black]   Next[/COLOR]
      [B][COLOR=blue]<<< see write-up >>>[/COLOR][/B]
    Next
  Next
  Selection = Arr
End Sub

Use these code lines in place of the ones highlighted in red and blue...

1. Remove Numeric characters
[COLOR=red][B]Red:[/B][/COLOR] If Mid(Arr(X, Y), Z, 1) Like "#" Then Arr(X, Y) = Mid(Arr(X, Y), Z) = "0"
[B][COLOR=blue]Blue:[/COLOR][/B] Arr(X, Y) = Replace("0", "")
 
2. Remove Alphabetic characters
[B][COLOR=red]Red:[/COLOR][/B] If Mid(Arr(X, Y), Z, 1) Like "[A-Za-z]" Then Arr(X, Y) = Mid(Arr(X, Y), Z) = "A"
[B][COLOR=blue]Blue:[/COLOR][/B] Arr(X, Y) = Replace("A", "")
 
3. Remove Non-Numeric characters
[COLOR=red][B]Red:[/B][/COLOR] If Mid(Arr(X, Y), Z, 1) Like "[!0-9]" Then Arr(X, Y) = Mid(Arr(X, Y), Z) = "A"
[COLOR=blue][B]Blue:[/B][/COLOR] Arr(X, Y) = Replace("A", "")
 
4. Remove Non Alphabetic characters
[B][COLOR=red]Red:[/COLOR][/B] If Mid(Arr(X, Y), Z, 1) Like "[!A-Za-z]" Then Arr(X, Y) = Mid(Arr(X, Y), Z) = "0"
[B][COLOR=blue]Blue:[/COLOR][/B] Arr(X, Y) = Replace("0", "")
 
5. Remove Non Alpha-Numeric characters
[COLOR=red][B]Red:[/B][/COLOR] If Mid(Arr(X, Y), Z, 1) Like "[!A-Za-z0-9]" Then Arr(X, Y) = Mid(Arr(X, Y), Z) = "@"
[B][COLOR=blue]Blue:[/COLOR][/B] Arr(X, Y) = Replace("@", "")
 
6. Remove Unprintable characters
[COLOR=red][B]Red:[/B][/COLOR] If Asc(Arr(X, Y)) < 32 Then Arr(X, Y) = Mid(Arr(X, Y), Z) = vbTab
[B][COLOR=blue]Blue:[/COLOR][/B] Arr(X, Y) = Replace(vbTab, "")

I did not actually test these, but they should work for you without any problems.

 

[JoeMo]

This has had some (not rigorous) testing, but I expect it will be slower than what Rick posted if you have a very large range to operate on.

Sub RemoveCharacters()
'---------------------------------------------------------------------
'There are 6 sections to this module, each is called indvidually
'to perform one of the following functions:
'1)Remove numeric characters from all cells in a selection
'2)Remove alphabetic characters from all cells in a selection
'3)Remove non-numeric characters from all cells in a selection
'4)Remove non-alphabetic characters from all cells in a selection
'5)Remove non-alpha-numeric characters from all cells in a selection
'6)Remove non-printable characters from all cells in a selection
'---------------------------------------------------------------------
Dim rng As Range, c As Range, ans, msg As String

Set rng = Application.InputBox("Select a range for removal of character type you will specify next", Type:=8)
msg = "Enter 1 to remove numeric characters from your selection" & vbNewLine & vbNewLine
msg = msg & "Enter 2 to remove alphabetic characters from your selection" & vbNewLine & vbNewLine
msg = msg & "Enter 3 to remove non-numeric characters from your selection" & vbNewLine & vbNewLine
msg = msg & "Enter 4 to remove non-alphabetic characters from your selection" & vbNewLine & vbNewLine
msg = msg & "Enter 5 to remove non-alpha-numeric characters from your selection" & vbNewLine & vbNewLine
msg = msg & "Enter 6 to remove non-printable characters from your selection"

ans = InputBox(msg, "CHOOSE CHARACTER TYPE")
If ans = "" Then Exit Sub
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
Select Case ans
    Case 1: Call RemoveNumeric(rng)
    Case 2: Call RemoveAlpha(rng)
    Case 3: Call RemoveNonNumeric(rng)
    Case 4: Call RemoveNonAlpha(rng)
    Case 5: Call RemoveNonAlphaNumeric(rng)
    Case 6: Call RemoveNonPrintable(rng)
    Case Else: MsgBox "Entry must be from 1 to 6": Exit Sub
End Select
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub
Sub RemoveNumeric(rng As Range)
'1) Remove all numeric characters
For i = 48 To 57
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
End Sub
Sub RemoveAlpha(rng As Range)
'2) Remove alphabetic characters
For i = 65 To 90
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, UCase(c.Value), Chr(i)) > 0 Then
                c.Replace Chr(i), ""  'Upper case letters
                c.Replace Chr(i + 32), ""  'Lower case Letters
            End If
        End If
    Next c
Next i
End Sub
Sub RemoveNonNumeric(rng As Range)
'3) Remove non-numeric characters (numeric chars are 48-57)
For i = 0 To 47
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 58 To 255
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
End Sub
Sub RemoveNonAlpha(rng As Range)
'4) Remove non-alphabetic characters
For i = 0 To 64
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 91 To 96
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 123 To 255
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
End Sub
Sub RemoveNonAlphaNumeric(rng As Range)
'5)Remove non-alpha-numeric characters
For i = 0 To 47
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 58 To 64
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 91 To 96
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
For i = 123 To 255
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
End Sub
Sub RemoveNonPrintable(rng As Range)
'6)Remove non-printable characters
For i = 0 To 31
    For Each c In rng
        If Not IsEmpty(c) Then
            If InStr(1, c.Value, Chr(i)) > 0 Then
                c.Replace Chr(i), ""
            End If
        End If
    Next c
Next i
End Sub

 

[zaska]

Thank you for the valuable and kind support

Regards,
Zaska

 

[ElBombay]

Hello Board,

First, a Thank You to Rick and JoeMo for a useful solution, and to Zaska for phrasing the initial question in a searchable form. It allowed me to get my work done on Thursday evening and then indulge my interest in the problem over the weekend.

JoeMo's mention of slowness led me to work on the attached code (RmvChars) as an entertaining puzzle. The fact that it fundementally consists of the work done by Rick and JoeMo, or that Zaska got his solution within 6 hours of asking for it is a classic example of why "a good plan today is much better than a great plan tomorrow". I just hope this helps one of our fellow members somewhere down the road.

ElBombay

'-----------------------------------------------------------------------
Sub RmvChars() '
'A "Streamlining" of work posted by 'Rick Rothstein & JoeMo on Jan 28th, 2012
'
'There are 6 sections to this module, each is called indvidually
'to perform one of the following functions:
'1)Remove numeric characters from all cells in a selection
'2)Remove alphabetic characters from all cells in a selection
'3)Remove non-numeric characters from all cells in a selection
'4)Remove non-alphabetic characters from all cells in a selection
'5)Remove non-alpha-numeric characters from all cells in a selection
'6)Remove non-printable characters from all cells in a selection
'---------------------------------------------------------------------
'
Dim cElement As String, cMsg As String, cTitle As String
Dim iOption As Integer
Dim rTable As Range

    cMsg = "1) Remove numeric characters" & vbNewLine & vbNewLine
    cMsg = cMsg & "2) Remove alphabetic characters" & vbNewLine & vbNewLine
    cMsg = cMsg & "3) Remove non-numeric characters" & vbNewLine & vbNewLine
    cMsg = cMsg & "4) Remove non-alphabetic characters" & vbNewLine & vbNewLine
    cMsg = cMsg & "5) Remove non-alpha-numeric characters" & vbNewLine & vbNewLine
    cMsg = cMsg & "6) Remove non-printable characters"

    cTitle = "CHOOSE CHARACTER TYPE(s) to REMOVE (0 to EXIT)"
    iOption = xGet_Option(cMsg, cTitle)
    If iOption = 0 Then Exit Sub
                                
    Set rTable = Application.InputBox _
            ("Select a range for removal of character type you will specify next", Type:=8)
                                
    Arr = rTable.Value
    For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
            cElement = Arr(i, 2)
            cElement = zRemove_Char(cElement, iOption)
            Arr(i, 2) = cElement
                                
        Next
    Next
    rTable = Arr
                                
End Sub
'----------------------------------------------------------------------------
Function xGet_Option(cPrompt As String, cTitle As String) As Integer
'
' InputBox(Prompt, Title, Default, Left, Top,
'           HelpFile, HelpContextID, Type)
' 0=Formula; 1=Number; 2=String; 4=Boolean; 8=Cell or Range;
' 16 An error value, such as #N/A; 64 An array of values
'Return the number chosen from a tailored menu
'2/8/12
'
Dim iChoice As Integer
Dim cPrefix As String

On Error GoTo GetOptError
    
    Do
        iChoice = Application.InputBox(cPrefix & cPrompt, Title:=cTitle, Type:=1)
        
        If iChoice = 0 Then
            GoTo GetOptError
                                
        ElseIf iChoice > 6 Then
            cPrefix = iChoice & " isn't an option.  Choose from the menu presented."
                                
        Else
            cPrefix = ""
                                
        End If
    Loop Until cPrefix = ""
    xGet_Option = iChoice
                                
GetOptError:
    If Err.Number = 0 Then
        'Exit normally
        On Error GoTo 0
                                
    Else
         zMisc_Error "x"
                                
    End If
End Function
'----------------------------------------------------------------------------
Sub zMisc_Error(x)
            MsgBox ("Write down number of Unexpected Error.  Call Jim." & vbCr & vbCrLf _
                        & Err.Number & ": " & Err.Description)


End Sub
'----------------------------------------------------------------------------
Function zRemove_Char(cString As String, iOpt As Integer) As String
'
'Remove characters of a certain pre-selected type from a string
'2/13/12
'
Dim bMark As Boolean
Dim cChar As String, cRmvFlag As String, cTest As String
                                
    Select Case iOpt
    Case 1                          'Remove NUMERICS
        cTest = "[0-8]"          'Save some nano-seconds; '9' arrives pre-flagged, as does 'A'
        cRmvFlag = "9"
                                
    Case 2                          'Remove ALPHABETICS
        cTest = "[B-Za-z]"
        cRmvFlag = "A"
                                
    Case 3                          'Remove non-NUMERICS
        cTest = "[!0-9]"
        cRmvFlag = "A"
                                
    Case 4                          'Remove non-ALPHABETICS
        cTest = "[!A-Za-z]"
        cRmvFlag = "9"
                                
    Case 5                          'Remove "special chars (@, %.etc)
        cTest = "[!A-Za-z0-9]"
        cRmvFlag = "@"
                                
    End Select
                                
    For i = 1 To Len(cString)
        cChar = Mid(cString, i, 1)
        bMark = 0
        If iOpt = 6 Then                      'Better ID is needed here
            iAsc = Asc(Mid(cString, i, 1))
            If iAsc = 63 Then               'non-printables all evluate to '?', ASC #63
                bMark = 1
            
            End If
            cRmvFlag = vbTab
                                
        Else
            If cChar Like cTest Then bMark = 1
                                
        End If
        If bMark Then cString = Replace(cString, cChar, cRmvFlag)
        
        
    Next
    cString = Replace(cString, cRmvFlag, "")
    zRemove_Char = cString                      'Return the updated value
                                
End Function

 

[ElBombay]

I just posted an improved (and tested) version of the RmvChars code but accidently attached it to a related thread called "Multiple choice input boxes". Please search that thread if you're interested in the code posted 2 days ago. Oops.

 

[chirp]

this would be my take on it...very brute force, as it loops through the contents of each cell, but who needs built in functions anyway right!!

Option Explicit

Public Enum whatOperation
    remNumbers = 1
    remAlpha = 2
    remNonNumbers = 4
    remNonAlpha = 8
    remNonPrintable = 16
End Enum

Public Const numEnums = 5

'works for chrs 0-255
Public Function removeChars(rng As Range, _
                            Optional whatOp As whatOperation = remNonPrintable, _
                            Optional tst As Boolean)
Dim enumArr As Variant, tmpVar As Variant
Dim boolEnum() As Boolean, fTest As Boolean, boolByte() As Boolean
Dim i As Long, uBnd2 As Long, j As Long, k As Long, tCnt As Long
Dim bArr() As Byte

tst = False
On Error GoTo exitFunc
If rng Is Nothing Then GoTo exitFunc
'Set rng = rUsedrange(rng) 'custom function, makes sure only searching used range

'get array of component powers
enumArr = splitEnums(whatOp, fTest)
If Not fTest Then GoTo exitFunc

'set boolean array (array just to add some convenience)
'note that if a value other than specified enumerated vals are entered this will error
ReDim boolEnum(0 To numEnums - 1)
For Each tmpVar In enumArr
    boolEnum(tmpVar) = True
Next

'messy bit
'****************************************************************************
'****************************************************************************
'preset decision array

ReDim boolByte(0 To 255)

'numbers
If boolEnum(0) Then
    For i = 48 To 57
        boolByte(i) = True
    Next
End If

'alpha
If boolEnum(1) Then
    For i = 65 To 90
        boolByte(i) = True
        boolByte(i + 32) = True
    Next
End If

'non numeric
If boolEnum(2) Then
    For i = 0 To 255
        If i < 48 Then
            boolByte(i) = True
        ElseIf i > 57 Then
            boolByte(i) = True
        End If
    Next
End If

'non alpha
If boolEnum(3) Then
    For i = 0 To 255
        If i < 65 Then
            boolByte(i) = True
        ElseIf i > 90 Then
            If i < 97 Then
                boolByte(i) = True
            ElseIf i > 122 Then
                boolByte(i) = True
            End If
        End If
    Next
End If

'non printable
If boolEnum(4) Then
    For i = 0 To 31
        boolByte(i) = True
    Next
    boolByte(127) = True
    boolByte(129) = True
    boolByte(141) = True
    boolByte(143) = True
    boolByte(144) = True
    boolByte(157) = True
End If
'****************************************************************************
'****************************************************************************
'end of  messy bit

'set array from range
If rng.Cells.count > 1 Then
    tmpVar = rng.Value2
Else
    ReDim tmpVar(1, 1)
    tmpVar(1, 1) = rng.Value2
End If

'get ubound save a bit of time if lots of rows
uBnd2 = UBound(tmpVar, 2)

'main loop
For i = 1 To UBound(tmpVar)
    For j = 1 To uBnd2
        If tmpVar(i, j) <> vbNullString Then
            bArr = CStr(tmpVar(i, j))
            For k = 0 To UBound(bArr) Step 2
                If Not boolByte(bArr(k)) Then
                    bArr(tCnt) = bArr(k)
                    tCnt = tCnt + 2
                End If
            Next
            tmpVar(i, j) = Left$(bArr, tCnt / 2)
            tCnt = 0
        End If
    Next
Next

'set array back into range
rng = tmpVar

tst = True
exitFunc:
End Function

Public Function splitEnums(totEnum As Long, _
                            Optional tst As Boolean) As Variant
Dim i As Long, maxPower As Long
Dim retArr As Variant

tst = False
On Error GoTo exitFunc

If totEnum < 1 Then Exit Function
ReDim retArr(0 To 31) 'max size of long

Do While totEnum <> 0
    maxPower = getPower(totEnum)
    retArr(i) = maxPower
    totEnum = totEnum - 2 ^ maxPower
    i = i + 1
Loop

ReDim Preserve retArr(0 To i - 1)
splitEnums = retArr

tst = True
exitFunc:
End Function

'returns the largest power of some base within a number
Public Function getPower(num, _
                        Optional base As Long = 2) As Long

getPower = Int(Round(Log(num) / Log(base), 15)) '15 maximum precision
End Function

 

[carlsonloggie]

Sorry to be a bother, but I've got a problem using Rick Rothstein's code. Excel 2010 stops compiling when it hits the "Replace" statement. Any ideas, because I haven't a clue?


Sub ReplaceNonPrintableCharacters()
Dim X As Long, Y As Long, Z As Long,
Arr As Variant Arr = Selection.Value
For X = LBound(Arr) To UBound(Arr)
For Y = LBound(Arr, 2) To UBound(Arr, 2)
For Z = 1 To Len(Arr(X, Y))
If Asc(Arr(X, Y)) < 32 Then Arr(X, Y) = Mid(Arr(X, Y), Z) = vbTab
Next
Arr(X, Y) = Replace(vbTab, "")
Next
Next
Selection = Arr
End Sub

 

[Rick Rothstein]

Sorry to be a bother, but I've got a problem using Rick Rothstein's code. Excel 2010 stops compiling when it hits the "Replace" statement. Any ideas, because I haven't a clue?

Interesting... I cannot see the code the OP posted unless I reply to the message. For those who (do not) see the same thing, here is his code reformatted to display correctly...

Sub ReplaceNonPrintableCharacters()
  Dim X As Long, Y As Long, Z As Long, Arr As Variant
  Arr = Selection.Value
  For X = LBound(Arr) To UBound(Arr)
    For Y = LBound(Arr, 2) To UBound(Arr, 2)
      For Z = 1 To Len(Arr(X, Y))
        If Asc(Arr(X, Y)) < 32 Then Arr(X, Y) = Mid(Arr(X, Y), Z) = vbTab
      Next
      [COLOR=#ff0000][B]Arr(X, Y) = Replace(vbTab, "")[/B][/COLOR]
    Next
  Next
  Selection = Arr
End Sub

As for why the Replace function is not working... it is missing an argument. Replace takes three arguments... the text to search, the text to find and the text to replace it with. I think this is the code line the OP was trying to create...

Arr(X, Y) = Replace(Arr(X, Y), vbTab, "")