extract number from text

[Shweta]

Hi All,

I need a VBA code for extracting number from the given text.

My data is
<TABLE style="WIDTH: 74pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=98 border=0><COLGROUP><COL style="WIDTH: 74pt; mso-width-source: userset; mso-width-alt: 3584" width=98><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; WIDTH: 74pt; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" width=98 height=20>Col A
shweta(31056)
</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>anju(31004)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>ankit(31038)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>neeru(31029)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>roshan(31040)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>rupesh31063)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>asha(31085)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>lokesh(32861)</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; BORDER-BOTTOM: #e0dfe3; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>kavita(31095)</TD></TR></TBODY></TABLE>

I am able to do it with below function.

Function extract_id(s As Range)
Dim i, j As Integer
For j = 1 To Len(s)
If VBA.IsNumeric(Mid(s, j, 1)) Then
extract_id = extract_id & VBA.Mid(s, j, 1)
End If
Next j
End Function

But I want to do it with loop on command button, my coding is

Private Sub CommandButton1_Click()
Dim i, j As Integer
Dim mylr1 As Long
Dim wkst1 As Worksheet
Dim rnge As Range
Set wkst1 = Sheets("c")
mylr1 = wkst1.Range("A" & Rows.Count).End(xlUp).Row
rnge = wkst1.UsedRange.Count
For i = 1 To mylr1 - 1
For j = 1 To Len(rnge)
If VBA.IsNumeric(Mid(rnge, j, 1)) Then
wkst1.Range("C" & i).Value = wkst1.Range("C" & i).Value & VBA.Mid(rnge, j, 1)
End If
Next j
Next i
End Sub

But its not working.

Please help me out.

Thanks,
shweta

 

[Rick Rothstein]

I believe this code will be faster...

Private Sub CommandButton1_Click()
  With Worksheets("Sheet4").Columns("A")
    .Replace "*(", "", xlPart
    .Replace ")", "", xlPart
  End With
End Sub

 

[Shweta]

Thanks Rick,

I want the ID in the next column.

Shweta

 

[Rick Rothstein]

Okay, try this code then...

Private Sub CommandButton1_Click()
  Dim LastRow As Long
  With Worksheets("C")
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("B1:B" & LastRow).Value = .Range("A1:A" & LastRow).Value
    With .Columns("B")
      .Replace "*(", "", xlPart
      .Replace ")", "", xlPart
    End With
  End With
End Sub

 

[Shweta]

Thanks Rick,Your coding is working perfectly.

But I want to know can't we do it with just a simple loop. I think this can be done by loop also.

Or I can also create a function in the module and call that function within the loop.

Need your suggestion.


Shweta

 

[Shweta]

I would also like to know if you dont mind why we used xlpart.
I have never used this earlier.

 

[Ron Coderre]

Another VBA option...

Sub NumsToNextCol()
Dim RE As Object
Dim cCell As Range
Set RE = CreateObject("vbscript.regexp")
Set cCell = [C1]
RE.Pattern = "\D"
RE.Global = True
Do Until cCell.Value = ""
    cCell.Offset(ColumnOffset:=1).Value = RE.Replace(cCell.Value, "")
    Set cCell = cCell.Offset(RowOffset:=1)
Loop
End Sub

Is that something you can work with?

 

[Rick Rothstein]

But I want to know can't we do it with just a simple loop. I think this can be done by loop also.

Yes (assuming you consider this loop simpler)...

Private Sub CommandButton1_Click()
  Dim X As Long, LastRow As Long, OpenParen As Long
  With Worksheets("Sheet4")
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    For X = 1 To LastRow
      OpenParen = InStr(Cells(X, "A").Value, "(")
      If OpenParen Then Cells(X, "B").Value = Replace(Mid(Cells(X, "A").Value, OpenParen + 1), ")", "")
    Next
  End With
End Sub

The code I posted earlier will be faster (it does its work all at once rather than visiting each cell individually). I'm guessing that you probably will not have enough rows of data to make the time difference noticeable.

I would also like to know if you dont mind why we used xlpart.
I have never used this earlier.

It tells the Replace method to look inside the text in the cell instead of trying to match the entire contents of the cell.

 

[Shweta]

This one is also working fine,

But I am in the initial stage of VBA.So I would like to know if I creat a function in module
Function extract_id(s As Range)
Dim i, j As Integer
For j = 1 To Len(s)
If VBA.IsNumeric(Mid(s, j, 1)) Then
extract_id = extract_id & VBA.Mid(s, j, 1)
End If
Next j
End Function

And call it in my loop

Private Sub CommandButton1_Click()
Dim X As Long, LastRow As Long, OpenParen As Long
With Worksheets("Sheet4")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For X = 1 To LastRow
Call Extract_id
next X
end with
end sub

Is it possible?

 

[gregtx81]

Here is what you're trying to do...

Function extract_id(s As Range) As String
    Dim returnval As String
    Dim i, j As Integer
    For j = 1 To Len(s.Value)
        If VBA.IsNumeric(Mid(s.Value, j, 1)) Then
            returnval = returnval & VBA.Mid(s, j, 1)
        End If
    Next j
    extract_id = returnval
End Function



Private Sub test()
Dim X As Long, LastRow As Long, OpenParen As Long
With Worksheets("Sheet4")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For X = 1 To LastRow
    .Range("C" & X).Value = extract_id(.Range("A" & X))
Next X
End With
End Sub