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
[TABLE="width: 425"]
<tbody>[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

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