To Pull out Certain Set of Data from a Cell [ Urgent ]

[New_Here]

Hi Good Evening from Sri Lanka,

Guys I have a massive challenge here, I normally wouldn't post URGENT, If it isn't.

Please help if possible.

I am only looking for a UDFs or Formulas. Not interested in Macro as lots of sensitive data and numbers are present and I don't want to be in a mess. UDFs or a formulaS would easily help me Target what I need here.

Data I have :-

Cell A1 = Phone: 81-74568943 Fax: -
Cell A2 = Phone: 51-83-9498756, 5583772359 Fax: 61-88-4932516
Cell A3 = Phone: 51-6785239556, Fax: 31-13-45225335
Cell A4 = Phone: 51-6785239556, Fax: 31-13-45225335, Mobile: -

What I need :-

B1 = Phone (As a data which we have pulled out from A1)
C1 = 81-74568943
D1 = Fax
E1 = - (Or N/A - Not the N/A Error Message or a value! error message, But just the letters : N/A)
F1 = Mobile
G1 = - (Or N/A - Not the N/A Error Message or a value! error message, But just the letters : N/A)

Similarly, I need to get the same outcome for the A2:A4,

I wouldn't mind 2 contact Numbers in the same cell with a coma separating it. ex : Situation in A2

Please Help Me. Thank You so Much Every Lady and Gentleman out there !

[Paul_Hossler]

Try this

The function is array entered so select 6 cells (say B1:G1) put the formula in and Control+Shift+Enter -- that will add the { }'s -- you don't do that


Capture.JPG

Option Explicit
Function BreakOut(s As String) As Variant
    Dim v As Variant
    Dim aOut As Variant
    Dim i As Long
    Dim s1 As String
    
    Application.Volatile
        
    s1 = s
    
    
    s1 = Replace(s1, ":", vbNullString)
    
    If s1 Like "*[0-9], [0-9]*" Then
        s1 = Replace(s1, ", ", Chr(1))
    End If
    
    v = Split(s1, " ")
    
    ReDim aOut(0 To 5)
    For i = LBound(aOut) To UBound(aOut)
        aOut(i) = vbNullString
    Next I
    
    
    For i = LBound(v) To UBound(v)
        v(i) = Replace(v(i), Chr(i), ", ")
        
        If v(i) = "-" Then
            aOut(i) = "N/A"
        ElseIf Right(v(i), 1) = "," Then
            aOut(i) = Left(v(i), Len(v(i)) - 1)
        Else
            aOut(i) = v(i)
        End If
    Next I
    
    BreakOut = aOut
End Function

[New_Here]

Try this

The function is array entered so select 6 cells (say B1:G1) put the formula in and Control+Shift+Enter -- that will add the { }'s -- you don't do that


Capture.JPG

Option Explicit
Function BreakOut(s As String) As Variant
    Dim v As Variant
    Dim aOut As Variant
    Dim i As Long
    Dim s1 As String
    
    Application.Volatile
        
    s1 = s
    
    
    s1 = Replace(s1, ":", vbNullString)
    
    If s1 Like "*[0-9], [0-9]*" Then
        s1 = Replace(s1, ", ", Chr(1))
    End If
    
    v = Split(s1, " ")
    
    ReDim aOut(0 To 5)
    For i = LBound(aOut) To UBound(aOut)
        aOut(i) = vbNullString
    Next I
    
    
    For i = LBound(v) To UBound(v)
        v(i) = Replace(v(i), Chr(i), ", ")
        
        If v(i) = "-" Then
            aOut(i) = "N/A"
        ElseIf Right(v(i), 1) = "," Then
            aOut(i) = Left(v(i), Len(v(i)) - 1)
        Else
            aOut(i) = v(i)
        End If
    Next I
    
    BreakOut = aOut
End Function

Woahhhh !!!!!!!!!!!!!! Thanks a Gazillion Brother.... Thank you so much for making My Life Easy with Excel... How does this Function work exactly? As I noticed no any words from the Cell are explicitly mentioned to draw out, How exactly does this work and how can this be used for Future reference? Thank You Very Much.

[New_Here]

How should I remodel the above in Case; A1=Contact Person: James Anderson Designation: Proprietor >>> to B1=Contact Person, C1=James Anderson, D1=Designation, E1=Proprietor

?

New Thread opened as the current one is Solved.

http://www.vbaexpress.com/forum/show...086#post360086

[rlv]

'''
''' This function will return the Nth word in a string
'''
'''    Example: If AnyString = "This is a Test // - give [me] the ***eighth*** word"
'''              then ExtractWord(AnyString, " []-//*", 8) will return the string "eighth"
'''
Function ExtractWord(ByVal AnyString As String, ByVal WordDelimiters As String, ByVal WordNumber As Long) As String
    Dim SA() As String
    Dim ResultWord As String, Delimiter As String, MultiDelims As String
    Dim SLen As Long, I As Long, DCnt As Long, SPos As Long


    'reduce multiple word delimiters to a single delimiter
    SLen = Len(WordDelimiters)


    If SLen > 1 Then
        Delimiter = Left(WordDelimiters, 1)
        For I = 1 To SLen
            AnyString = VBA.Replace(AnyString, Mid(WordDelimiters, I, 1), Delimiter)
        Next I
        WordDelimiters = Delimiter
    End If


    'Collapse multiple sequential delimiters to a single delimiter
    For DCnt = 20 To 2 Step -2
        MultiDelims = String(DCnt, WordDelimiters)
        SPos = InStr(AnyString, MultiDelims)
        If SPos > 0 Then
            AnyString = Replace(AnyString, MultiDelims, WordDelimiters)
        End If
    Next


    If Right(AnyString, 1) = WordDelimiters Then
        AnyString = Left(AnyString, Len(AnyString) - 1)
    End If


    If Left(AnyString, 1) = WordDelimiters Then
        AnyString = Mid(AnyString, 2, Len(AnyString) - 1)
    End If


    'extract desired word
    SA = Split(AnyString, WordDelimiters)
    If WordNumber > 0 And WordNumber <= UBound(SA) + 1 Then
        ResultWord = SA(WordNumber - 1)
    Else
        ResultWord = "N/A"  'vbNullString
    End If
    ExtractWord = ResultWord
End Function

[mdmackillop]

Please don't quote entire posts; only quote those sections relevant to your question.

[New_Here]

Thank you for your Reply RLV, But I think I need to start VBA from Basic to get a complete understanding