Option Explicit
Sub Extract_Please()
Dim n As Long
Dim rgx As Object
Dim My_NUm As Object
Dim ws As Worksheet
Dim lrd%, I%
Set rgx = CreateObject("VBScript.RegExp")
Set ws = Worksheets("Sheet1")
lrd = ws.Cells(Rows.Count, "D").End(3).Row
ws.Range("F3:G" & lrd).ClearContents
With rgx
.Global = True
.MultiLine = True
.Pattern = "(\d+)*(\d+)"
For I = 3 To lrd
If .Test(Range("D" & I)) Then
Set My_NUm = .Execute(Range("D" & I))
For n = 0 To My_NUm.Count - 1
ws.Range("f" & I).Offset(, n) = My_NUm.Item(n)
Next n
End If
Next I
End With
Set rgx = Nothing: Set ws = Nothing
Set My_NUm = Nothing
End Sub
HiTry this macro
Code:Option Explicit Sub Extract_Please() Dim n As Long Dim rgx As Object Dim My_NUm As Object Dim ws As Worksheet Dim lrd%, I% Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Sheet1") lrd = ws.Cells(Rows.Count, "D").End(3).Row ws.Range("F3:G" & lrd).ClearContents With rgx .Global = True .MultiLine = True .Pattern = "(\d+)*(\d+)" For I = 3 To lrd If .Test(Range("D" & I)) Then Set My_NUm = .Execute(Range("D" & I)) For n = 0 To My_NUm.Count - 1 ws.Range("f" & I).Offset(, n) = My_NUm.Item(n) Next n End If Next I End With Set rgx = Nothing: Set ws = Nothing Set My_NUm = Nothing End Sub
Hi SalimTry this macro
Code:Option Explicit Sub Extract_Please() Dim n As Long Dim rgx As Object Dim My_NUm As Object Dim ws As Worksheet Dim lrd%, I% Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Sheet1") lrd = ws.Cells(Rows.Count, "D").End(3).Row ws.Range("F3:G" & lrd).ClearContents With rgx .Global = True .MultiLine = True .Pattern = "(\d+)*(\d+)" For I = 3 To lrd If .Test(Range("D" & I)) Then Set My_NUm = .Execute(Range("D" & I)) For n = 0 To My_NUm.Count - 1 ws.Range("f" & I).Offset(, n) = My_NUm.Item(n) Next n End If Next I End With Set rgx = Nothing: Set ws = Nothing Set My_NUm = Nothing End Sub
Dear Bosco,Dear Bosco,
Thanks for attending to the query.
That was absolutely perfect.
Great work.
Regards
Ranjit