Macro to delete all text from cells and leave numbers

Sort by date Sort by votes
In Chirp's modification of my code the declrations Dim RegEx As Object outside the subroutine was missed. It's not correct as it's too slow!

Please test this modification:
Rich (BB code): 

Dim RegEx As Object '<-- Don't forget this declaration!
Sub ZVI_Txt2Num()
  Dim a() As Variant, c As Long, cs As Long, r As Long, v 
  If RegEx Is Nothing Then
    ' Initiation only once for the fast performing
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    ' [^] means except, i.e. "character non in set"
    ' :   - colon symbol
    ' \d  - digits
    ' \s  - whitespaces (tab, space, line breaks)
    RegEx.Pattern = "[^:\d ]" '  use =[^:\d\s] if required
  End If
  ' Copy range values into array
  With Selection
    If .Count > 1 Then a = .Value Else ReDim a(1 To 1, 1 To 1): a(1, 1) = .Value
  End With
  ' Process array
  cs = UBound(a, 2)
  With RegEx
    For r = 1 To UBound(a)
      For c = 1 To cs
        v = a(r, c)
        If VarType(v) = vbString Then
          a(r, c) = Trim$(.Replace(v, vbNullString))
        End If
      Next
    Next
  End With
  ' Copy back array to the range
  Selection.Value = a()
End Sub

Time test subroutine:
Rich (BB code): 

Sub TimeTest()
  
  Dim t As Single
  
  InitRange
  t = Timer
  ZVI_Txt2Num
  t = Timer - t
  Debug.Print "zvi", Round(t, 3)
  
  InitRange
  t = Timer
  another
  t = Timer - t
  Debug.Print "mirabeau", Round(t, 3)
  
End Sub

Sub InitRange()
  Range("A1:A50000") = "00:00:03:23 00:00:05:23 The quick brown fox jumps over the lazy brown dog!"
  Range("A1:A50000").Select ' <-- as selection is used in the testing code
End Sub

zvi 0.938
mirabeau 3.078
 
Last edited:
Upvote 0

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
not to beat this to death but

@ miribeau as to your ??? im rather interested does my code not work?

here is a cosmetically updated version...

Code: 
Option Explicit
Option Base 0

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

'used in a few range functions
Public Enum cornerCell
    leftTop = 0
    rightTop = 1
    leftBottom = 2
    rightBottom = 3
End Enum

'sub to operate on all cells in a range
Sub delChars(rng As Range, _
                            Optional whatOp As whatOperation = remNonPrintable, _
                            Optional excludeChrs As String, _
                            Optional includeChrs As String, _
                            Optional tst As Boolean)

Dim enumArr As Variant, tmpVar As Variant
Dim boolEnum() As Boolean, fTest As Boolean, boolByte(0 To 255) As Boolean
Dim i As Long, j As Long, k As Long, ubnd2 As Long, tCnt As Long
Dim bArr() As Byte

Const numEnums = 6 'number of possible enum vals

tst = False
On Error GoTo exitFunc
If rng Is Nothing Then GoTo exitFunc 'just exits when no valid input
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

'check if all chars are deleted
If boolEnum(0) Then
    If boolEnum(2) Then
        rng.ClearContents
        tst = True
        GoTo exitFunc
    End If
End If
        
If boolEnum(1) Then
    If boolEnum(3) Then
        rng.ClearContents
        tst = True
        GoTo exitFunc
    End If
End If

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

'sets "exclude" bytes to true
If excludeChrs <> vbNullString Then
    bArr = excludeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = True
    Next
ElseIf boolEnum(5) Then  '5 is only custom
    tst = True
    GoTo exitFunc
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
            Else: i = i + 9
            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 (these are preference based to some extent)
    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 If

'Include str gets preference over exclude
If includeChrs <> vbNullString Then
    bArr = includeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = False
    Next
End If

'****************************************************************************
'****************************************************************************
'end of  messy bit

'set array from range
If rng.Cells.Count > 1 Then
    tmpVar = rng.Value2
Else
    ReDim tmpVar(1 To 1, 1 To 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
If ubnd2 <> 1 Then 'this test saves an extremely small amount of time, could remove
    For i = 1 To UBound(tmpVar)
        For j = 1 To ubnd2
            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
            Next
            If tCnt < UBound(bArr) Then tmpVar(i, j) = LeftB$(bArr, tCnt)
            tCnt = 0
        Next
    Next
Else
    For i = 1 To UBound(tmpVar)
        bArr = CStr(tmpVar(i, 1))
        For k = 0 To UBound(bArr) Step 2
            If Not boolByte(bArr(k)) Then bArr(tCnt) = bArr(k): tCnt = tCnt + 2
        Next
        If tCnt < UBound(bArr) Then tmpVar(i, 1) = LeftB$(bArr, tCnt)
        tCnt = 0
    Next
End If

'set array back into range
rng.Value2 = tmpVar
'set tst var to true as no errors occurred
tst = True
exitFunc:
End Sub

'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 tst 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

tst = False
On Error GoTo exitFunc
If inString = vbNullString Then GoTo exitFunc

'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

'check if all chars are deleted
If boolEnum(0) Then
    If boolEnum(2) Then
        delCharsSN = vbNullString
        tst = True
        GoTo exitFunc
    End If
End If
        
If boolEnum(1) Then
    If boolEnum(3) Then
        delCharsSN = vbNullString
        tst = True
        GoTo exitFunc
    End If
End If

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

'get other chrs
If excludeChrs <> vbNullString Then
    bArr = excludeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = True
    Next
ElseIf boolEnum(5) Then
    delCharsSN = inString
    tst = True
    GoTo exitFunc
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 <> vbNullString 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)

tst = True
exitFunc:
End Function
'changes a string passed by ref, does not return anything itself
Function delCharsSE(inString As String, _
                            Optional whatOp As whatOperation = remNonPrintable, _
                            Optional excludeChrs As String, _
                            Optional includeChrs As String, _
                            Optional tst As Boolean)

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

tst = False
On Error GoTo exitFunc
If inString = vbNullString Then GoTo exitFunc

'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

'check if all chars are deleted
If boolEnum(0) Then
    If boolEnum(2) Then
        inString = vbNullString
        tst = True
        GoTo exitFunc
    End If
End If
        
If boolEnum(1) Then
    If boolEnum(3) Then
        inString = vbNullString
        tst = True
        GoTo exitFunc
    End If
End If

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

'get other chrs
If excludeChrs <> vbNullString Then
    bArr = excludeChrs
    For i = 0 To UBound(bArr) Step 2
        boolByte(bArr(i)) = True
    Next
ElseIf boolEnum(5) Then
    tst = True
    GoTo exitFunc
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 <> vbNullString 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 inString = LeftB$(bArr, tCnt)

tst = True
exitFunc:
End Function


'gets the real used range using the first/last col/row functions
Function rUsedrange(withinRange As Range, _
                            Optional LookIn As XlFindLookIn = xlFormulas, _
                            Optional showAllData As Boolean = False, _
                            Optional tst As Boolean) As Range
Dim lr As Long, fr As Long, lc As Long, fc As Long

tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange.Parent
    'will catch values that are in hidden rows/cols eiter way
    If showAllData Then If .FilterMode Then .showAllData
    lr = lastRow(withinRange, LookIn)
    If lr < 1 Then GoTo exitFunc
    fr = firstRow(withinRange, LookIn)
    lc = LastCol(withinRange, LookIn)
    fc = firstCol(withinRange, LookIn)
    Set rUsedrange = .Range(.Cells(fr, fc), .Cells(lr, lc))
End With

tst = True
exitFunc:
End Function

'THESE USE THE FIND METHOD FOR LAST/FIRST ROW/COL, use if searching full sheet/large range
'gets last/first row/column (searches within values or formulas)
'the find method seems to have an overhead of about .25 seconds/1000 calls
'the increase in time/range size is then about .7 seconds/2560000 searched cells/1000 calls

Public Function lastRow(withinRange As Range, _
                        Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long
Dim ar As Range, tmp As Long, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc

With withinRange
    If .Areas.Count < 2 Then
        lastRow = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByRows, xlPrevious).Row
    Else
        t = .Row + .Rows.Count - 1
        For Each ar In .Areas
            tmp = .Find("*", getCornerRange(ar, leftTop), LookIn, xlPart, xlByRows, xlPrevious).Row
            If tmp > lastRow Then
                lastRow = tmp
                If lastRow = t Then Exit For
            End If
        Next
    End If
End With
tst = True
exitFunc:
If lastRow < 1 Then lastRow = -1
End Function

Public Function LastCol(withinRange As Range, _
                        Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long
Dim ar As Range, tmp As Long, t As Long
tst = False
On Error GoTo exitFunc
With withinRange
    If .Areas.Count < 2 Then
        LastCol = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByColumns, xlPrevious).Column
    Else
        t = .Column + .Columns.Count - 1
        For Each ar In .Areas
            tmp = .Find("*", getCornerRange(ar, leftTop), LookIn, xlPart, xlByColumns, xlPrevious).Column
            If tmp > LastCol Then
                LastCol = tmp
                If LastCol = t Then Exit For
            End If
        Next
    End If
End With
tst = True
exitFunc:
If LastCol < 1 Then LastCol = -1
End Function

Public Function firstRow(withinRange As Range, _
                        Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long

Dim ar As Range, tmp As Long, notFirst As Boolean, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange
    If .Areas.Count < 2 Then
        firstRow = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByRows, xlNext).Row
    Else
        t = .Row
        For Each ar In .Areas
            tmp = .Find("*", getCornerRange(ar, rightBottom), LookIn, xlPart, xlByRows, xlNext).Row
            If tmp <> 0 Then
                If notFirst Then
                    If tmp < firstRow Then
                        firstRow = tmp
                        If firstRow = t Then Exit For
                    End If
                Else
                    notFirst = True
                    firstRow = tmp
                    If firstRow = t Then Exit For
                End If
            End If
            
        Next
    End If
End With

tst = True
exitFunc:
If firstRow < 1 Then firstRow = -1
End Function

Public Function firstCol(withinRange As Range, _
                        Optional LookIn As XlFindLookIn = xlFormulas, _
                        Optional tst As Boolean) As Long

Dim ar As Range, tmp As Long, notFirst As Boolean, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange
    If .Areas.Count < 2 Then
        firstCol = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByColumns, xlNext).Column
    Else
        t = .Column
        For Each ar In .Areas
            tmp = .Find("*", getCornerRange(ar, rightBottom), LookIn, xlPart, xlByColumns, xlNext).Column
            If tmp <> 0 Then
                If notFirst Then
                    If tmp < firstCol Then
                        firstCol = tmp
                        If firstCol = t Then Exit For
                    End If
                Else
                    notFirst = True
                    firstCol = tmp
                    If firstCol = t Then Exit For
                End If
            End If
        Next
    End If
End With

tst = True
exitFunc:
If firstCol < 1 Then firstCol = -1
End Function

'gets the specified corner of a range
'left top fastest, left bottom slowest

Function getCornerRange(rng As Range, _
                                Optional whichCorner As cornerCell = rightBottom, _
                                Optional tst As Boolean) As Range
Dim funcTest As Boolean
Dim lBnd As Long

tst = False
On Error GoTo exitFunc

'could use a "with" block here but of margninal impact
If rng.Areas.Count = 1 Then
    Select Case whichCorner
        Case 0 'lefttop
            Set getCornerRange = rng.Cells(1)
        Case 1 'right top
            Set getCornerRange = rng.Cells(rng.Columns.Count)
        Case 2 'left bottom
            Set getCornerRange = rng.Cells(rng.Rows.Count, 1)
        Case 3 'right bottom
            Set getCornerRange = rng.Cells(rng.Rows.Count, rng.Columns.Count)
    End Select
Else
    Set getCornerRange = getCornerRange(getBoundRange(rng, funcTest), whichCorner, tst)
    GoTo exitFunc
End If

tst = True
exitFunc:
End Function

Function getBoundRange(r As Range, _
                            Optional tst As Boolean) As Range
    ' Returns a single-area range bounding the areas in r
    ' pgc01 http://www.mrexcel.com/forum/showpos...64&postcount=3
    Dim i As Long
    
    tst = False
    On Error GoTo exitFunc
    If r Is Nothing Then Exit Function
    
    Set getBoundRange = r.Areas(1)
    For i = 2 To r.Areas.Count
        Set getBoundRange = Range(getBoundRange, r.Areas(i))
    Next i
    
    tst = True
exitFunc:
End Function

'returns 2^x components (binary parts) of a given number
'fairly slow. 1.0s/100000 for input=~70000
Function splitEnums(totEnum As Long, _
                            Optional tst As Boolean) As Variant
Dim i As Long, tmpVal As Long, tCnt As Long
Dim retArr As Variant

tst = False
On Error GoTo exitFunc

If totEnum < 1 Then GoTo exitFunc
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

tst = True
exitFunc:
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), 14)) '14 precision just to be safe
End Function

used like:

Code: 
sub test()
    delChars selection, remNonNumbers, , " :"
end sub
 
Upvote 0
Excelent result, Сhirp!
May be complicated a bit ;)
I'd also add Trim function to the result.
 
Upvote 0
chirp said:
not to beat this to death but

@ miribeau as to your ??? im rather interested does my code not work?
Click to expand...

chirp,

there was no suggestion that your code didn't work, i guess i was expecting you to provide the result.

your code is very fast. also i have to admire your stamina.
ZVI's update is fast too

after your and Vladimir's last posts i thought a bit more testing a good idea, so generated 50,000 rows with some testdata code and concluded

chirp 0.34 secs
ZVI 0.44 secs
mirabeau 0.97 secs

looks all good to me, although i was puzzled by the results of your own time testing.

a good fun thread :)
 
Upvote 0
mirabeau said:
...looks all good to me...

a good fun thread :)
Click to expand...
Returning to the initial discussion, your code is shorter and much clearer vs others.
This may cost the speed benefits of the comparable code :)
And yes - it’s nice indeed to see & analyze the different solutions shown here!
 
Upvote 0
absolutely agree in terms of what solution i would actually use mine is probably the worst as it is extremely confusing and muddled, with minimal difference in speed....i think all of its functionality can easily be replaced by using regEx...which is rather upsetting
 
Upvote 0
Hi I saw you post about deleting words and keeping only numbers. Works perfectly for me but I need to keep a space or seperator between each set of numbers.. I was trying to tweak your code but was unable.. Do you have any thoughts? Thanks so much for your time!
Jason
 
Upvote 0
Ron Coderre said:
OK...Here's what to do

• Select the workbook you want to contain the program
• ALT+F11...to open the VBA editor
• Insert.Module...to include a new general module in that workbook
• Tools.References
...Find one of the Microsoft VBScript Regular Expressions resources and check it, then click: OK
(I used: Microsoft VBScript Regular Expressions 5.5)
• Copy the below code and paste it into the new module:
Code: 
Public Function PullOnly(strSrc As String, CharType As String)
Dim RE As RegExp
Dim regexpPattern As String
Set RE = New RegExp
CharType = LCase(CharType)
Select Case CharType
    Case Is = "digits":
        regexpPattern = "\D"
    Case Is = "letters":
        regexpPattern = "\d"
    Case Else:
        regexpPattern = ""
End Select
RE.Pattern = regexpPattern
RE.Global = True
PullOnly = RE.Replace(strSrc, "")
End Function
 
Sub LeaveNumbers()
Dim cCell As Range
For Each cCell In Selection
    If cCell <> "" Then
        cCell.Value = "'" & PullOnly(cCell.Text, "digits")
    End If
Next cCell
End Sub

• Select the data range to be impacted in your worksheet
• ALT-F8...to see the list of available macros
• Select: LeaveNumbers
• Click: Run

Is that something you can work with?
Click to expand...

Is there a way to keep the symbols as well. I was trying to find CharTypes for symbols and then do another "Case Is", but I am not sure how to go about doing that. I have never used visual basic before, but can pick things up pretty quick.

If you could give me a quick lesson/ some pointers I would appreciate it.

Thanks!
 
Upvote 0
This is really cool. I saw someone ask about negative numbers. Is it possible to account for negative numbers with a macro like this? If so it would be very helpful for what I'm doing.
 
Upvote 0
Otto Hoering said:
Is it possible to account for negative numbers with a macro like this?
Click to expand...
Try this:
Rich (BB code): 
Function GetNumbers(Txt As String, Optional Index As Long, Optional Separator As String = ",")
' ZVI:2013-06-18 http://www.mrexcel.com/forum/excel-questions/545660-macro-delete-all-text-cells-leave-numbers.html
' Returns positive or negative number(s) from the string Txt.
' Arguments:
'   Index     - which number is returned from left/right side if positive/negative, 
'               if ommited or Index = 0 then list of all numbers is returned
'   Separator - list separator for the case Index = 0
 
  Dim a(), i As Long, x
  Static RegEx As Object
 
  If RegEx Is Nothing Then
    ' Initiate static object only once
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "-{0,1}((\d+)\.(\d+)|(\d+))"
  End If
 
  If Not RegEx.Test(Txt) Then
    GetNumbers = ""
    Exit Function
  End If
 
  With RegEx.Execute(Txt)
    Select Case Index
      Case 0
        ReDim a(1 To .Count)
        For i = 1 To .Count
          a(i) = .Item(i - 1)
        Next
        GetNumbers = Join(a, Separator)
      Case 1 To .Count
        GetNumbers = Val(.Item(Index - 1))
      Case -.Count To -1
        GetNumbers = Val(.Item(.Count + Index))
      Case Else
        GetNumbers = "#Index?"
    End Select
  End With
 
End Function
 
Sub Test()
  Dim Txt As String
  Txt = "RegExp test. Integer: 123; negative integer: -210, doubles: 45.67 or -89.10; Mixed x777a, others: @#$%^&*!"
  Debug.Print "All numbers", GetNumbers(Txt)
  Debug.Print "Index =  1", GetNumbers(Txt, 1)
  Debug.Print "Index =  2", GetNumbers(Txt, 2)
  Debug.Print "Index =  3", GetNumbers(Txt, 3)
  Debug.Print "Index = -1", GetNumbers(Txt, -1)
  Debug.Print "Index = -2", GetNumbers(Txt, -2)
  Debug.Print "Index = -3", GetNumbers(Txt, -3)
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
VBA macro for combining and deleting duplicate rows, and adding values from one column
Replies
0
Views
60
Darko
D
C
  • Solved
Find and Replace any values of 0 or more
Replies
8
Views
122
Fuji
F
zookeepertx
  • Solved
Trying (unsuccessfully) to pull a date from the middle of a string
2 3
Replies
23
Views
527
zookeepertx
zookeepertx
R
  • Question Question
Leave Database Time Tracking to equal full day after 8 hours
Replies
6
Views
314
NoSparks
N
Q
  • Question Question
VBA code to split by multiple delimiters and calculate
Replies
7
Views
203
bebo021999
B

Forum statistics

Threads
1,224,522
Messages
6,179,297
Members
452,903
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top