PDA

View Full Version : [SOLVED] To Pull out Certain Set of Data from a Cell [ Urgent ]



New_Here
04-21-2017, 08:12 AM
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
04-21-2017, 08:55 AM
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


18984





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
04-21-2017, 09:57 AM
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


18984





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
04-21-2017, 10:14 AM
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/showthread.php?59247-Please-Modify-this-VBA-for-New-Requirement-Or-Provide-a-New-One&p=360086#post360086

rlv
04-21-2017, 12:31 PM
'''
''' 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
04-21-2017, 01:06 PM
Please don't quote entire posts; only quote those sections relevant to your question.

New_Here
04-21-2017, 11:21 PM
Thank you for your Reply RLV, But I think I need to start VBA from Basic to get a complete understanding :)