Extracting multiple numbers from one string with blanks & text in it & put into separate columns

armchairandy

Board Regular
Joined
Mar 27, 2012
Messages
53
Hi

This is the problem. I have a column with something like the following:
Column B
Line 1 SS 2 d' FS 0 d
Line 2 SS 5 d' FF 6 d
Line 3 FS 0 d
Line 4 FF 0 d' SS 3 d' FS 0 d' FS 0 d' SS 3 d' FF 11 d'

And so on

each line can be and is different.

What I need is all the numbers extracted into separate columns
so the last line would read
C D E F G H
0 3 0 0 3 11

I have some code that I have found on this site (thank you)
Sub ExtractNumbers()
Dim rng As Range 'range to process
Dim arr As Variant 'array
Dim i As Long 'loop index
Dim col As Long 'column offset for output
Set rng = Sheets("Leads").Range("C1")
Do Until rng = ""
'split values into an array
'then loop through the array to determine if numeric
col = 3
arr = Split(rng.Value, " ")
For i = LBound(arr) To UBound(arr)
If IsNumeric(arr(i)) Then
col = col + 1
rng.Offset(, col).Value = arr(i)
End If
Next i
Set rng = rng.Offset(1, 0)
Loop
Set rng = Nothing
End Sub

This gives me exactly what I want but..................................
There are occasions when this code would need to process over 15,000 lines of similar data and the process is taking too long for this approach to be used.

Is there any way that this code could be quicker, or is there a formula I could use in subsequent columns instead - it would not matter if I had many columns of formula, as long as the process is quick.

Many thanks in advance

Andrew

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
NB:- 22 sec for 15K in column "A"
Results start column "B" On.
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Mar11
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] t
t = Timer
Ray = Range("A1", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    Sp = Split(Mid(CleanString(CStr(Ray(n, 1))), 2), ",")
    Cells(n, 2).Resize(, UBound(Sp)).Value = Sp
[COLOR="Navy"]Next[/COLOR] n
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Function CleanString(strIn [COLOR="Navy"]As[/COLOR] String) [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    [COLOR="Navy"]Dim[/COLOR] objRegex
    [COLOR="Navy"]Set[/COLOR] objRegex = CreateObject("vbscript.regexp")
    [COLOR="Navy"]With[/COLOR] objRegex
     .Global = True
     .Pattern = "[^\d]+"
    CleanString = .Replace(strIn, ",")
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] Function
Regards Mick
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try the following code, check 20,000 rows in 20 seconds

Code:
Sub ExtractNumbers2()
    Dim sh As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim k As Double
    
    Set sh = Sheets("Leads")
    Set rng = sh.Range("C1", sh.Range("C" & Rows.Count).End(xlUp))
    
    With CreateObject("scripting.dictionary")
        For Each cell In rng
            For k = 1 To Len(cell.Value)
                letra = Mid(cell.Value, k, 1)
                If Mid(cell.Value, k, 1) Like "[0-9]" Then
                    .Add cell.Row & k, Mid(cell.Value, k, 1)
                End If
            Next
            If .Count Then
                cell.Offset(0, 1).Resize(1, .Count) = .items
                .RemoveAll
            End If
        Next
    End With
    
    MsgBox "End"
    
End Sub
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Just an after thought.!!
My code assumes your data is in column "A" !!!!
 

armchairandy

Board Regular
Joined
Mar 27, 2012
Messages
53

ADVERTISEMENT

Hi

First of all, many thanks for such a quick response.

I added the macros.. and this is what I got.

DanteAmor - it ran ok, but it separated each individual number into separate columns, what I really need is if the number is 5 then this gets put in a column & if the number is 11 then 11 would be put into a column. Maybe I didn't explain myself enough, & I apologise for this.

MickG when I added the code in, it debugged at "Cells(n, 2).Resize(, UBound(Sp)).Value = Sp", I assume that I put the code in correct - I cut & pasted into a new module, but I am not experienced in VBA.

Regards

Andrew
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Did you try the code with your data in column "A" ???? (Ref:- Post#4)
NB:- There is also an Error, Add a 1 as shown in line below:-
Code:
Cells(n, 2).Resize(, UBound(Sp) [COLOR="#FF0000"][B][SIZE=4]+ 1[/SIZE][/B][/COLOR]).Value = Sp
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

With these changes for 15,000 rows it takes 14 seconds

Code:
Sub ExtractNumbers2()
    Dim sh As Worksheet, cell As Range, rng As Range
    Dim k As Double
    
    Application.ScreenUpdating = False
    
    Set sh = Sheets("Leads")
    Set rng = sh.Range("C1", sh.Range("C" & Rows.Count).End(xlUp))
    
    With CreateObject("scripting.dictionary")
        For Each cell In rng
            num = ""
            For k = 1 To Len(cell.Value)
                letra = Mid(cell.Value, k, 1)
                If Mid(cell.Value, k, 1) Like "[0-9]" Then
                    num = num & Mid(cell.Value, k, 1)
                Else
                    If num <> "" Then
                        .Add cell.Row & k, num
                        num = ""
                    End If
                End If
            Next
            If num <> "" Then .Add cell.Row & k + 1, num
            If .Count Then cell.Offset(0, 1).Resize(1, .Count) = .items
            .RemoveAll
        Next
    End With
        
    Application.ScreenUpdating = True
    MsgBox "End"
    
End Sub
 

armchairandy

Board Regular
Joined
Mar 27, 2012
Messages
53
MickG

That serves me right - should always read the references, I amended my sheet & it works fine, still having issues with time though, I tested on 269 rows it took 150 seconds the code has a timer box and it placed 279 numbers with the largest spread being over 8 columns.

Regards

Andrew
 

armchairandy

Board Regular
Joined
Mar 27, 2012
Messages
53
Dante

Made the changes ran the code and got almost identical results to MickG. Could the speed have something to do with either my computer or my workbook?


Regards

Andrew
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Dante

Made the changes ran the code and got almost identical results to MickG. Could the speed have something to do with either my computer or my workbook?

Regards

Andrew


As I said, on my computer it runs in 14 seconds for 15k.
There are versions of computers that are not very compatible with excel. Try another computer.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,543
Messages
5,529,456
Members
409,878
Latest member
DDhol
Top