Extract Numbers and copy into new cell

[bathingape]

Hi Guys, basically i have a spreadsheet that has about 1500 cells in one row that have a combination of text as well as a 5 digit number and what i want to do is copy that number from the cell and paste it into the adjacent cell. Here is an example

55 BROADWAY (Petty France) auto 44739 noisy intermittant

70 OLD BROAD AUTO 49875 Crackly line.

7am - 5pm - 70 OLD BROAD - Auto 49841 - Dead

ACTON TOWN Hearne House AUTO 46564 Dead

(Access 07:00 to 19:00 )...ACTON TOWN AUTO 46645 Interference. (bollo hse)


The number i need is the auto number which is always 5 digits long and can appear in any part of the text.

I did some research and came up with my own code to carry out this task but as i dont not fully understand VBA i find it very hard to rectify the problems i am having from the resources i have available. Here is my attemtped script which does not work and displays a run-time error '1004'.

Sub extractautonumber()

Do While Cells(x, x).Value <> ""
For Each MyCell In Selection
If MyCell.Value Like "*****" Then
MyCell.Copy = True
Range("x+1, x").Select
ActiveSheet.Paste
End If
Next
Loop

End Sub
If anyone could please shed any light on this issue and assist me in any way i would be extremly grateful. Many Thanks :)

[Bob Phillips]

Is each row spanning multiplke columns, in other words is the 5 digit number in a cell of its own?

[bathingape]

No the sample of the spread sheet i posted is how the data appears in each cell in one column.
So one cell in the column would conatin an example such as:

70 OLD BROAD AUTO 49875 Crackly line

Hope this helps

[Bob Phillips]

This seems to work okay



Public Sub ProcessData()
Dim i As Long, j As Long
Dim LastRow As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow

j = 1
Do While j > 0

If Mid$(.Cells(i, "A").Value, j, 5) Like "#####" Then

.Cells(i, "B").Value = Mid$(.Cells(i, "A").Value, j, 5)
j = 0
Else

j = InStr(j, .Cells(i, "A").Value, " ")
If j > 0 Then

j = j + 1
End If
End If
Loop
Next i
End With

End Sub