Hi Ramesh,
Supposing that no other split-sequences occur than space, underscore
or hyphen (or a combination of these), then following routine should
do the job...
Enjoy and let me know if it did help you out.
Kind regards
Paul Willekens
'=======================================================================
Sub ExtractNumber()
Dim cChar
Dim cNumber
Dim lDone
Dim lFount
Dim nLen
Dim nPos
Dim nRow
Dim nStart
nRow = 2
lDone = False
While lDone = False
cContent = Cells(nRow, 1)
nLen = Len(cContent)
cNumber = ""
If nLen < 1 Then
lDone = True
Else
For nPos = 1 To nLen
cChar = Mid(cContent, nPos, 1)
If IsNumeric(cChar) Then
If IsNumeric(Mid(cContent, (nPos + 1), 1)) Then
'this must be the number
lFound = False 'will be set True when the split-factor is
found
nStart = InStrRev(Left(cContent, nPos), " ") + 1
While nStart <= nLen
If Not lFound Then
cChar = Mid(cContent, nStart, 1)
If cChar = " " Or cChar = "_" Or cChar = "-" Then
cNumber = cNumber & "-"
lFound = True
cChar = Mid(cContent, (nStart + 1), 1)
If cChar = " " Or cChar = "_" Or cChar = "-" Then
nStart = nStart + 1
If Mid(cContent, (nStart + 1), 1) = " " Then
nStart = nStart + 1
End If
End If
Else
cNumber = cNumber & Mid(cContent, nStart, 1)
End If
nStart = nStart + 1
Else 'last part
nPos = InStr(nStart, cContent, " ")
If nPos = 0 Then
nPos = nLen
Else
nPos = nPos - 1
End If
cNumber = cNumber & Mid(cContent, nStart, (nPos - nStart
+ 1))
nStart = nLen + 1
End If
Wend
nPos = nLen
End If
End If
Next
If Not cNumber = "" Then
Cells(nRow, 2).Value = cNumber
End If
End If
nRow = nRow + 1
Wend
End Sub
'=======================================================================
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our Facebook Group @ http://www.facebook.com/group.php?gid=287779555678
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to [email protected]
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 6,800 subscribers worldwide and receive many nice notes about the
learning and support from the group.Let friends and co-workers know they can
subscribe to group at http://groups.google.com/group/excel-macros/subscribe
To unsubscribe from this group, send email to
excel-macros+unsubscribegooglegroups.com or reply to this email with the words
"REMOVE ME" as the subject.
