EXCEL vba - extract numbers from cell and paste into two different columns? - excel

Question

I have a spreadsheet with a load of random text and numbers in column A like so:
Column A
Row 1 = 471806121601 5205569 - 0007 Standard White Toilet Tissue 27
Row 2 = 471814121601 5206177 - 0014 Premium White Toilet Tissue 6
Row 3 = 471814121601 5206178 - 0007 Premium White Toilet Tissue 27
Row 4 = 471806121601 5206180 - 0014 Premium Kitchen Towel 2x75l 6
I have about 2000 lines in total. In each cell, is a Purchase order number (12 digits) and an item number next to it (7 digits).
I am trying to extract the po number and put it into column B and extract the item number and put it into column C
Column B Column C
471806121601 5205569
471814121601 5206177
471814121601 5206178
471806121601 5206180
Here is my code:
Option Explicit
Sub main()
Dim cell As Range
Dim arr As Variant, arrElem As Variant
With Worksheets("Orders") '<--| change "Strings" to your actual worksheet name
For Each cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
arr = Split(Replace(cell.Value, " ", " "), " ") '<--| change "A"'s to your actual relevant column index
For Each arrElem In arr
If IsNumeric(arrElem) Then
If Len(arrElem) = 12 Then cell.Offset(0, 1).Value = arrElem
End If
Next arrElem
Next cell
End With
Dim cell2 As Range
Dim arr2 As Variant, arrElem2 As Variant
With Worksheets("Orders") '<--| change "Strings" to your actual worksheet name
For Each cell2 In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
arr2 = Split(Replace(cell2.Value, " ", " "), " ") '<--| change "A"'s to your actual relevant column index
For Each arrElem2 In arr2
If IsNumeric(arrElem2) Then
If Len(arrElem2) = 7 Then cell2.Offset(0, 3).Value = arrElem2
End If
Next arrElem2
Next cell2
End With
End Sub
This code does work. However it takes absolutely ages and only does one line at a time...Slowly.
Is there a quicker way of doing this? Thanks

Answer 1

If your PO and IN are always the same length in col B put
=MID(A2, 1, 12)
And in col C
=MID(A2, 14, 7)
However if your number change but are always the first two swap the above for,
=MID(A2,1,FIND(" ",A2,1)-1)
And
=MID(A2, FIND(" ", A2, 1)+1, 7)
Respectively.

Answer 2

just use split(string,delimiter)(0) and (1) why replace the space, just use that as the delim. If Row # is in, then use (1) and (2), or you could consider split(split(input,"-")," ") maybe a little faster, not sure though. Also, once you're done no need to complete the loop, so consider, do until with flags rather than for next, although exit for is available
Formula wise, it could be done using something like this
=MID(D1,FIND("é",SUBSTITUTE(D1," ","é",3)),FIND("é",SUBSTITUTE(D1," ","é",4))-FIND("é",SUBSTITUTE(D1," ","é",3)))
and
=MID(D1,FIND("é",SUBSTITUTE(D1," ","é",4)),FIND("é",SUBSTITUTE(D1," ","é",5))-FIND("é",SUBSTITUTE(D1," ","é",4)))