CODEWITHSUNDEEP
regexexcelvba
milltek
milltek

Reputation: 11

VBA to edit excel column of data

I have a requirement to edit a column of data where each cell has to be edited to remove all non-numeric characters. The only data that I need are actual numbers and a decimal point if one was there originally. I found a piece of code that removes everything with the exception of a "%" character. If someone could look at the code below and let me know how to modify it I would be appreciative. Examples of the type of data I am editing are as follows Complete cell contents enclosed in quotes). "3" "2.5%" "17 nks" "3.00 %" "4 VNS"

Here's the code I have used;

Sub RemoveAlphas()
'' Remove alpha characters from a string.
Dim intI As Integer
Dim rngR As Range, rngRR As Range
Dim strNotNum As String, strTemp As String

Set rngRR = Selection.SpecialCells(xlCellTypeConstants, _
xlTextValues)

For Each rngR In rngRR
    strTemp = ""
    For intI = 1 To Len(rngR.Value)
        If Mid(rngR.Value, intI, 1) Like "[0-9,.]" Then
            strNotNum = Mid(rngR.Value, intI, 1)
        Else: strNotNum = ""
        End If
        strTemp = strTemp & strNotNum
    Next intI
    rngR.Value = strTemp
Next rngR

End Sub

Thanks.

Upvotes: 1

Views: 162

Answers (3)

brettdj
brettdj

Reputation: 55692

Try the RexExp below which builds on my code from Remove non-numeric characters from a range of cells, and uses variant arrays for speed.

The RegExp pattern is [^\d\.]+

Sub KillNonNumbers()
    Dim rng1 As Range
    Dim rngArea As Range
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngCalc As Long
    Dim objReg As Object
    Dim X()

    On Error Resume Next
    Set rng1 = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
    If rng1 Is Nothing Then Exit Sub
    On Error GoTo 0

    'See Patrick Matthews excellent article on using Regular Expressions with VBA
    Set objReg = CreateObject("vbscript.regexp")
    objReg.Pattern = "[^\d\.]+"
    objReg.Global = True

   'Speed up the code by turning off screenupdating and setting calculation to manual
   'Disable any code events that may occur when writing to cells
    With Application
        lngCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Test each area in the user selected range

    'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
    For Each rngArea In rng1.Areas
        'The most common outcome is used for the True outcome to optimise code speed
        If rngArea.Cells.Count > 1 Then
           'If there is more than once cell then set the variant array to the dimensions of the range area
           'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
            X = rngArea.Value2
            For lngRow = 1 To rngArea.Rows.Count
                For lngCol = 1 To rngArea.Columns.Count
                    'replace the leading zeroes
                    X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), vbNullString)
                Next lngCol
            Next lngRow
            'Dump the updated array sans leading zeroes back over the initial range
            rngArea.Value2 = X
        Else
            'caters for a single cell range area. No variant array required
            rngArea.Value = objReg.Replace(rngArea.Value, vbNullString)
        End If
    Next rngArea

    'cleanup the Application settings
    With Application
        .ScreenUpdating = True
        .Calculation = lngCalc
        .EnableEvents = True
    End With

    Set objReg = Nothing
End Sub

Upvotes: 0

peege
peege

Reputation: 2477

If you are getting the results you need with the exception of a percent sign, you can insert into this part of your code a Replace function:

    Next intI
    strTemp = Replace(strTemp, "%", "")   'Remove the % sign and replace with nothing.
    rngR.Value = strTemp
Next rngR

Upvotes: 0

Mark Moore
Mark Moore

Reputation: 510

This can be done using Regex as shown below- Have tested with your exact sample data and works for me:

Sub RemoveAlphas()
'' Remove alpha characters from a string.
Dim intI As Integer
Dim rngR As Range, rngRR As Range
Dim strNotNum As String, strTemp As String
Dim RegEx As Object

   Set rngRR = Selection.SpecialCells(xlCellTypeConstants, _
   xlTextValues)
   Set RegEx = CreateObject("VBScript.RegExp")
   RegEx.Global = True
   RegEx.Pattern = "[^\d.]+"
   For Each rngR In rngRR
      rngR.Value = RegEx.Replace(rngR.Value, "")
   Next rngR
End Sub

Upvotes: 1

Related Questions