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

#### armchairandy

##### Board Regular
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
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.

Andrew

<tbody>
</tbody>

### 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
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
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 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
Just an after thought.!!
My code assumes your data is in column "A" !!!!

#### armchairandy

##### Board Regular

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

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 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
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
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
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
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.

Replies
1
Views
104
Replies
4
Views
68
Replies
14
Views
192
Replies
1
Views
25
Replies
3
Views
58