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

[armchairandy]

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>

 

[MickG]

Try this:-
NB:- 22 sec for 15K in column "A"
Results start column "B" On.

[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

 

[DanteAmor]

Try the following code, check 20,000 rows in 20 seconds

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]

Just an after thought.!!
My code assumes your data is in column "A" !!!!

 

[armchairandy]

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]

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

Cells(n, 2).Resize(, UBound(Sp) [COLOR="#FF0000"][B][SIZE=4]+ 1[/SIZE][/B][/COLOR]).Value = Sp

 

[DanteAmor]

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

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]

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]

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]

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.