Code is not giving correct output

Shweta

Well-known Member
Joined
Jun 5, 2011
Messages
514
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.

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

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

ashish koul

Board Regular
Joined
Dec 30, 2010
Messages
56
see if it helps

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

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,400
Office Version
  1. 365
Platform
  1. Windows
Here's another approach to consider. It doesn't require manually looping through every character of every cell.
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,668
Messages
5,626,180
Members
416,166
Latest member
Archimed

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top