Remove numeric characters in a string

[PATSYS]

Hi all, I have below sample values in column A:

q1w2e3r4
asdqw123
w12345fgh
12cv34yu

Is there a way that a formula in column B will return a value in column A but excluding all the numeric characters?

Thanks in advance.

 

[Trebor76]

Hi PATSYS,

Besides a VBA User Defined Function (UDF) solution, the following formula (though 'cluncky') works:

=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A2,0,""),1,""),2,""),3,""),4,""),5,""),6,""),7,""),8,""),9,"")

Just change the cell reference to suit.

Regards,

Robert

 

[JamesW]

Edit: Removed.

 

[Trebor76]

Hi,

Ty:

=SUBSTITUTE(A1,{1,2,3,4,5,6,7,8,9,0},"")

Based on the user's sample data this only removes the 1 from the alphanumeric string.

 

[chirp]

From what i can tell (if anyone was wondering) to do this through a VBA sub is with regex, as this would suggest, and to do it all at once like:

Sub RegexReplace(rng As Range, _
                      ByVal replace_what As String, _
                      ByVal replace_with As String)


Dim RE As Object
Dim v
Dim i As Long
Set RE = CreateObject("vbscript.regexp")
v = rng.Value2
RE.Pattern = replace_what
RE.Global = True
With RE
    For i = 1 To UBound(v)
        v(i, 1) = .Replace(v(i, 1), replace_with)
    Next
End With
rng = v
End Sub

Used like: RegexReplace Selection, "\d", ""

This is the best and obviously most versatile way of doing it, but not suited for a UDF as you have to create that object every time (could be sped up by setting a reference) which is slow.

I am not sure why I made this originally but if you have a limited number of cells (read on the order of 100's not 1000's) then the following function is not too bad:

Option Explicit


'used in delete char function
Public Enum whatOperation
    remNumbers = 1
    remAlpha = 2
    remNonNumbers = 4
    remNonAlpha = 8
    remNonPrintable = 16
    remOnlyCustom = 32
End Enum


'can be used as a UDF in a spreadsheet, operates on a single string (cell)
Function delCharsSN(inString As String, _
                            Optional whatOp As whatOperation = remNonPrintable, _
                            Optional excludeChrs As String, _
                            Optional includeChrs As String, _
                            Optional bTst As Boolean) As String


Dim enumArr As Variant, tmpVar As Variant
Dim boolEnum() As Boolean, fTest As Boolean, boolByte(0 To 255) As Boolean
Dim i As Long, K As Long, tCnt As Long
Dim bArr() As Byte
'number of possible enum vals
Const numEnums = 6


'Const sSOURCE As String = "delCharsSN()"
'bTst = True
'On Error GoTo errHandle
'If Len(inString) = 0 Then Err.Raise glHANDLED_ERROR, sSOURCE, gsIN_STR_NULL


'get array of component powers
enumArr = splitEnums(whatOp, bTst) ': If Not bTst Then Err.Raise glHANDLED_ERROR


'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


'check if all chars are deleted
If boolEnum(0) Then If boolEnum(2) Then delCharsSN = "": GoTo ErrorExit
If boolEnum(1) Then If boolEnum(3) Then delCharsSN = "": GoTo ErrorExit


'messy bit
'****************************************************************************
'****************************************************************************


'get other chrs
If excludeChrs <> "" Then
    bArr = excludeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = True
    Next
ElseIf boolEnum(5) Then
    delCharsSN = inString
    GoTo ErrorExit
End If


If Not boolEnum(5) Then
    '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
End If


'get other chrs
If includeChrs <> "" Then
    bArr = includeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = False
    Next
End If


bArr = inString
For K = 0 To LenB(inString) - 1 Step 2
    If Not boolByte(bArr(K)) Then bArr(tCnt) = bArr(K): tCnt = tCnt + 2
Next
If tCnt = K Then delCharsSN = inString Else delCharsSN = LeftB$(bArr, tCnt)


ErrorExit:
    Exit Function
errHandle:
    bTst = False
    'If bMain_Err(msMOD, sSOURCE) Then Stop: Resume Else Resume ErrorExit
End Function


'returns 2^x components (binary parts) of a given number
'fairly slow. likely a better way of doing this using MATH!
Function splitEnums(totEnum As Long, _
                            Optional bTst As Boolean) As Variant
Dim i As Long, tmpVal As Long, tCnt As Long
Dim retArr As Variant


'Const sSOURCE As String = "splitEnums()"
'bTst = True
'On Error GoTo errHandle


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


For i = 0 To getPower(totEnum)
    If (2 ^ i And totEnum) Then retArr(tCnt) = i: tCnt = tCnt + 1
Next


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


ErrorExit:
    Exit Function
errHandle:
    bTst = False
    'If bMain_Err(msMOD, sSOURCE) Then Stop: Resume Else Resume ErrorExit
End Function


'returns the largest power of some base within a number
Function getPower(num, Optional Base As Long = 2) As Long
    On Error Resume Next
    getPower = Int(Round(Log(num) / Log(Base), 15)) '15 maximum precision
End Function

You can use this to remove different combinations of characters, and can include/exclude custom strings like:

delCharsSN("skv34%j4#kd",remAlpha, "#","sk")="sk34%4k"
delCharsSN("skv34%j4#kd",remNonAlpha) = "skvjkd"
delCharsSN("skv34%j4#kd",remOnlyCustom,"j4")="skv3%#kd"

It can remove just numbers, just alphabetic, non-numbers, non-alphabetic, non-printable, or custom. All in all a mildly useful function that is implemented a little more efficiently than a simple looping replace and could be helpful in certain circumstances.

While I am sharing rather long and unnecessary code here is another fun function that lets you declare modestly sized arrays using MATLAB like notation:

'this function returns a 1D array if a column vector, and a 2D array otherwise
'based on a string like matlab "1,2,3;1,2,3" outputs a 2x3 matrix, converting # to doubles
Function ArrayTxt(ByVal sTxt As String, _
                Optional lBnd1 As Long = 1, _
                Optional lBnd2, _
                Optional bTst As Boolean)
Dim vArr, vTmp, v
Dim i As Long, cnti As Long, cntj As Long, lNumRows As Long, lNumCols As Long, lR As Long, lC As Long
Dim lColon As Long, lSemi As Long, lComa As Long, lLbnd As Long, lUbnd As Long
Dim lRevColon As Long
Dim dStep As Double
Dim b2D As Boolean


'Const sSOURCE As String = "ArrayTxt()"
'bTst = True
'On Error GoTo errHandle


sTxt = delDupSpaces(sTxt)
If Len(sTxt) = 0 Then GoTo ErrorExit
If IsMissing(lBnd2) Then lBnd2 = 1 Else b2D = True


'get indexes of delimeters
lColon = InStr(1, sTxt, ":")
lSemi = InStr(1, sTxt, ";")
lComa = InStr(1, sTxt, ",")
'special case like ArrayTxt(1:step:1000)
If lSemi = 0 And lComa = 0 And lColon > 0 Then
    lRevColon = InStrRev(sTxt, ":")
    lLbnd = CLng(Mid(sTxt, 1, lColon - 1))
    lUbnd = CLng(Mid(sTxt, lRevColon + 1))
    If chrCount(sTxt, ":") = 2 Then
        dStep = CDbl(Mid(sTxt, lColon + 1, lRevColon - lColon - 1))
    Else: dStep = 1
    End If
    
    cnti = Int((lUbnd - lLbnd) / dStep)
    
    If Not b2D Then
        ReDim vTmp(lBnd1 To cnti + lBnd1)
        For i = 0 To cnti
            vTmp(i + lBnd1) = lLbnd + dStep * i
        Next i
    Else
        ReDim vTmp(lBnd1 To cnti + lBnd1, lBnd2 To lBnd2)
        For i = 0 To cnti
            vTmp(i + lBnd1, lBnd2) = lLbnd + dStep * i
        Next i
    End If
    ArrayTxt = vTmp: GoTo ErrorExit
End If


'fixes any colon operators (slow...could be improved)
'this function converts to an array, then back to text, then back to an array
'just a little tricky to do efficiently with all the joining etc
If lColon > 0 Then sTxt = fixMatrixInput(sTxt)


If lSemi = 0 Then
    vTmp = Split(sTxt, ",")
    cnti = lBnd1
    
    If Not b2D Then
        ReDim vArr(lBnd1 To UBound(vTmp) - LBound(vTmp) + lBnd1)
        For Each v In vTmp
            If IsNumeric(v) Then vArr(cnti) = CDbl(v) Else vArr(cnti) = v
            cnti = cnti + 1
        Next v
    Else
        ReDim vArr(lBnd1 To UBound(vTmp) - LBound(vTmp) + lBnd1, lBnd2)
        For Each v In vTmp
            If IsNumeric(v) Then vArr(cnti, lBnd2) = CDbl(v) Else vArr(cnti, lBnd2) = v
            cnti = cnti + 1
        Next v
    End If
Else
    lNumRows = chrCount(sTxt, ";") + 1
    lNumCols = (chrCount(sTxt, ",") + lNumRows) / lNumRows
    ReDim vArr(lBnd1 To lBnd1 + lNumRows - 1, lBnd2 To lBnd2 + lNumCols - 1)
    sTxt = Replace(sTxt, ";", ",")
    vTmp = Split(sTxt, ",")
    lR = lBnd1: lC = lBnd2
    For i = LBound(vTmp) To UBound(vTmp)
        If IsNumeric(vTmp(i)) Then vArr(lR, lC) = CDbl(vTmp(i)) Else vArr(lR, lC) = vTmp(i)
        If lC = lNumCols Then
            lC = lBnd2
            lR = lR + 1
        Else: lC = lC + 1
        End If
    Next i
End If


ArrayTxt = vArr


ErrorExit:
    Exit Function
errHandle:
    'bTst = False
    'If bMain_Err(msMOD, sSOURCE) Then Stop: Resume Else Resume ErrorExit
End Function


Function fixMatrixInput(ByVal sText As String) As String
Dim cl As Long
Do
cl = InStr(1, sText, ":")
If cl > 0 Then sText = replaceColonEntry(sText, cl) Else Exit Do
Loop
fixMatrixInput = sText
End Function


Function replaceColonEntry(sText As String, colNDX As Long) As String
Dim i As Long, st2 As Long, cnt As Long, lInd As Long
Dim v, vTmp
Dim sChr As String, sTmp As String, sRpl As String, sLeft As String, sRight As String


ReDim v(1 To 3) 'left, step, right
sRpl = Replace(sText, ";", ",")


i = 1
Do While colNDX - i > 0
    If Mid(sRpl, colNDX - i, 1) = "," Then Exit Do
    i = i + 1
Loop
v(1) = CDbl(Mid(sRpl, colNDX - i + 1, i - 1))
If colNDX - i > 0 Then sLeft = Mid(sText, 1, colNDX - i)


st2 = InStr(colNDX + 1, sRpl, ":"): lInd = InStr(colNDX + 1, sRpl, ",")
If (st2 < lInd Or lInd < 1) And st2 > 0 Then
    i = 1
    Do While colNDX + i <= Len(sRpl)
        sChr = Mid(sRpl, colNDX + i, 1)
        If sChr = "," Or sChr = ":" Then Exit Do
        i = i + 1
    Loop
    v(2) = CDbl(Mid(sRpl, colNDX + 1, i - 1))
Else
    v(2) = 1
    st2 = colNDX
End If


i = 1
Do While st2 + i <= Len(sRpl)
    sChr = Mid(sRpl, st2 + i, 1)
    If sChr = "," Or sChr = ":" Then Exit Do
    i = i + 1
Loop
v(3) = CDbl(Mid(sRpl, st2 + 1, i - 1))
If st2 + i <= Len(sRpl) Then sRight = Mid(sText, st2 + i)


cnt = Int((v(3) - v(1)) / v(2))


ReDim vTmp(0 To cnt)
For i = 0 To cnt
    vTmp(i) = v(1) + v(2) * i
Next i


replaceColonEntry = sLeft & Join(vTmp, ",") & sRight
End Function


'****************************************************************************************************
'Description:
'|This function returns the input string with all interior duplicate spaces removed
'|Uses a "manual" method for strings <600 characters long
'|Uses application.trim for strings >600 characters long
'|Can be used as a UDF in a spreadsheet
'Modified:
'|06/27/12-Added error handling
'****************************************************************************************************


Function delDupSpaces(str As String, _
                        Optional bTst As Boolean) As String


Dim i As Long, iNew As Long, lBnd As Long
Dim tByte() As Byte, skipBlank As Boolean


'Const sSOURCE As String = "delDupSpaces()"
'bTst = True
'On Error GoTo errHandle


If InStr(1, str, "  ") < 1 Then delDupSpaces = Trim$(str): GoTo ErrorExit


If Len(str) < 600 Then
    tByte = str
    iNew = LBound(tByte)
    lBnd = iNew


    For i = lBnd To UBound(tByte) Step 2
        If tByte(i) <> 32 Then
            skipBlank = False
            tByte(iNew) = tByte(i)
            iNew = iNew + 2
        ElseIf Not skipBlank Then
            tByte(iNew) = 32
            skipBlank = True
            iNew = iNew + 2
        End If
    Next
    
    delDupSpaces = Trim$(Left$(tByte, iNew / 2))
Else
    delDupSpaces = Application.Trim$(str)
End If


ErrorExit:
    Exit Function
errHandle:
'    bTst = False
'    If bMain_Err(msMOD, sSOURCE) Then Stop: Resume Else Resume ErrorExit
End Function


'****************************************************************************************************
'Description:
'|This function returns the number of times the character 'chr' appears in the string 'str'
'Modified:
'|06/27/12-Added error handling
'****************************************************************************************************


Function chrCount(str As String, chr As String, _
                        Optional compareType As VbCompareMethod = vbBinaryCompare, _
                        Optional bTst As Boolean) As Long
'Const sSOURCE As String = "chrCount()"
'bTst = True
On Error GoTo errHandle


If Len(str) = 0 Then GoTo ErrorExit 'Err.Raise glHANDLED_ERROR, sSOURCE, gsIN_STR_NULL
If Len(chr) = 0 Then GoTo ErrorExit 'Err.Raise glHANDLED_ERROR, sSOURCE, gsIN_STR_NULL
If Len(chr) <> 1 Then GoTo ErrorExit 'Err.Raise glHANDLED_ERROR
chrCount = Len(str) - Len(Replace(str, chr, "", , , compareType))
ErrorExit:
    Exit Function
errHandle:
'    bTst = False
'    If bMain_Err(msMOD, sSOURCE) Then Stop: Resume Else Resume ErrorExit
End Function

This lets you declare an array like:

join(arraytxt("1:3:22"),",")="1,4,7,10,13,16,19,22"
join(arraytxt("1:2:22"),",")="1,3,5,7,9,11,13,15,17,19,21"
join(arraytxt("1:2:22,1:5"),",")="1,3,5,7,9,11,13,15,17,19,21,1,2,3,4,5"

This works in 2D as well like: tst= arraytxt("1:4;2:5"), the number of columns has to be the same in each row obviously.

If anybody did happen to read this then !!! Would love if you had any suggestions/improvements

 

[Rick Rothstein]

Besides a VBA User Defined Function (UDF) solution

Here is such a UDF...

Function NoDigits(S As String) As String
  Dim X As Long
  NoDigits = S
  For X = 0 To 9
    NoDigits = Replace(NoDigits, X, "")
  Next
End Function

HOW TO INSTALL UDFs
------------------------------------
If you are new to UDFs, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. You can now use NoDigits just like it was a built-in Excel function. For example,

=NoDigits(A1)

 

[chirp]

why would you possibly want a 5 line piece of code when you have a perfectly good (and probably slightly faster even with all the duplicated effort) 200+ option?

 

[PATSYS]

Hi all,

Thanks for all your posts.

I havel adopted the suggestion of Rick Rothstein.

 

[PATSYS]

Here is such a UDF...

Function NoDigits(S As String) As String
  Dim X As Long
  NoDigits = S
  For X = 0 To 9
    NoDigits = Replace(NoDigits, X, "")
  Next
End Function

HOW TO INSTALL UDFs
------------------------------------
If you are new to UDFs, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. You can now use NoDigits just like it was a built-in Excel function. For example,

=NoDigits(A1)

Hi Rick,

If I want to add the characters ";" and "#" in the list of those to be removed, how do I tweak the code?

Is there something I can do to make X as an array e.g.

X = array(0,1,2,3,4,5,6,7,8,9,;,#) ?

Thanks

 

[Rick Rothstein]

Hi Rick,

If I want to add the characters ";" and "#" in the list of those to be removed, how do I tweak the code?

Is there something I can do to make X as an array e.g.

X = array(0,1,2,3,4,5,6,7,8,9,;,#) ?

Instead of hard-coding the characters in an array, here is a UDF which lets you pass the characters in as a text string...

Function RemoveCharacters(Text As String, Remove As String) As String
  Dim X As Long
  RemoveCharacters = Text
  For X = 1 To Len(Remove)
    RemoveCharacters = Replace(RemoveCharacters, Mid(Remove, X, 1), "")
  Next
End Function

The first argument is the text you to do the replacement in and the second argument is a text string containing the character you want to remove from the Text. So, for the characters you mentioned, you could call this function like this...

=RemoveCharacters(A1,"0123456789:#")

or, if you put the characters 0123456789:# into cell B1, you could call this function like this...

=RemoveCharacters(A1,B1)