Code is not giving correct output

[Shweta]

Hi All,

I am using the below code for extracting numbers from an alphanumeric text. But this is not giving the correct output. Please suggest what changes are required to make it work.

Sub extract_numbers()
Dim i As Integer
Dim j As Integer
Dim arr As Variant


arr = Application.Transpose(Sheet1.Cells(1, 1).CurrentRegion.Resize(, 1).Value)


For i = LBound(arr) To UBound(arr)


For j = 1 To Len(arr(i))


If IsNumeric(VBA.Mid(arr(i), j, 1)) Then


arr(i) = arr(i) & VBA.Mid(arr(i), j, 1)
End If


Next
Next


Sheet1.Cells(1, 2).Resize(UBound(arr), 1).Value = Application.Transpose(arr)
End Sub

Regards,
Shweta

 

[ashish koul]

see if it helps

Sub extract_numbers()
Dim i As Integer, j As Integer
Dim arr As Variant
Dim c As String
arr = Application.Transpose(Sheet1.Cells(1, 1).CurrentRegion.Resize(, 1).Value)
For i = LBound(arr) To UBound(arr)
c = ""
    
    For j = 1 To Len(arr(i))
        
        If IsNumeric(Mid(arr(i), j, 1)) Then
            c = c & Mid(arr(i), j, 1)
        End If
    
    Next
arr(i) = c
Next
Sheet1.Cells(1, 2).Resize(UBound(arr), 1).Value = Application.Transpose(arr)
End Sub

 

[Shweta]

Thanks Ashish! It's working.

 

[Peter_SSs]

Here's another approach to consider. It doesn't require manually looping through every character of every cell.

Sub Extract_Numbers_2()
    Dim RX As Object
    Dim arr As Variant
    Dim i As Long
    Dim s As String
    
    Set RX = CreateObject("VBScript.RegExp")
    RX.Global = True
    RX.Pattern = "\D"
    With Sheet1.Cells(1, 1).CurrentRegion.Resize(, 1)
        arr = .Value
        For i = 1 To UBound(arr, 1)
            s = arr(i, 1)
            arr(i, 1) = RX.Replace(s, "")
        Next i
        .Offset(, 1).Value = arr
    End With
End Sub