Get a Cell into a Standard Format depending on its Contents - UDF/Formula Only

Hi Guys Good Morning from Sri Lanka,

I want a favor with regards to getting a Cell formatted to a standard Cell.

What I have:

A1=Green Hoodie: 5
A2=Green Hoodie: 10 Black Hoodie: -
A3=White Hoodie: 4

What I Need:

B1=Green Hoodie: 5 Black Hoodie: N/A White Hoodie: N/A
B2=Green Hoodie: 10 Black Hoodie: N/A White Hoodie: N/A
B3=Green Hoodie: N/A Black Hoodie: N/A White Hoodie: 4

At times we get the Number along with the words like Pieces, or pcs...but that's completely Fine. Therefore when you make the UDF/formuala please regard the number string which appear here irrelevant as a Text or Numeric

ex:
A1=Green Hoodie: 5pcs
A1=Green Hoodie: 5Nos

Thank you...

Try this

Code:

---

Option Explicit

'very similar to
'http://www.vbaexpress.com/forum/showthread.php?59247-Please-Modify-this-VBA-for-New-Requirement-Or-Provide-a-New-One

Function BreakOut3(s As String) As String
    Dim v As Variant, v1 As Variant
    Dim i As Long, n As Long
    Dim s1 As String, s2 As String
    Dim aOut(1 To 3, 1 To 2) As String
   
    Application.Volatile
       
    aOut(1, 1) = "Green"
    aOut(2, 1) = "Black"
    aOut(3, 1) = "White"
    aOut(1, 2) = "N/A"
    aOut(2, 2) = "N/A"
    aOut(3, 2) = "N/A"
   
       
    s1 = s
    s1 = Replace(s1, " Hoodie", vbNullString)
    s1 = Replace(s1, " Green", Chr(1) & "Green")
    s1 = Replace(s1, " Black", Chr(1) & "Black")
    s1 = Replace(s1, " White", Chr(1) & "White")
   
   
    v = Split(s1, Chr(1))
   
    For i = LBound(v) To UBound(v)
        v1 = Split(v(i), ":")
        Select Case v1(0)
            Case "Green": n = 1
            Case "Black": n = 2
            Case "White": n = 3
        End Select
               
        If IsNumeric(v1(1)) Then
            aOut(n, 2) = v1(1)
               
        Else
            Do While Len(v1(1)) > 0 And Not IsNumeric(v1(1))
                v1(1) = Left(v1(1), Len(v1(1)) - 1)
            Loop
            If Len(v1(1)) > 0 Then
                aOut(n, 2) = v1(1)
            End If
        End If
    Next i
   
   
    s1 = vbNullString
    For i = LBound(aOut, 1) To UBound(aOut, 1)
        s1 = s1 & aOut(i, 1) & " Hoodie: " & aOut(i, 2) & IIf(i < UBound(aOut, 1), " ", vbNullString)
    Next i
   
    BreakOut3 = s1
End Function

---

Yes Brother, requirement change depending on our customer and what we have to do with their Data, its hard to over see some expectations of them...

Thanks a lot for your support...

Just asking as the UDF looks massive, will this not slow down the Excel, due to the amount of coding?

...and another problem is I do not Know VBA,

Specially from BreakOut1&2 I could have never come up with this to code...

Thank you again and again for your kind support...

Quote:

---

Originally Posted by New_Here

Just asking as the UDF looks massive, will this not slow down the Excel, due to the amount of coding?

---

In general, the number of VBA lines does not affect performance nearly as much as things such as For/Next loops and the necessity to handle special cases such as "pcs" and "Nos"

Quote:

---

Originally Posted by New_Here

...and another problem is I do not Know VBA,

---

If you have a little programming experience, VBA is not that hard to become familiar with. I'm still impressed by many of the real VBA pros and experts that visit here

Read through a macro and hit F1 to get the help on any unfamiliar terms, but many times you can make a fairly good guess

For example, "Replace" replaces something, "Split" splits something, etc.

While Thanking you again...

I have a small request but a bit big in Size... :crying: :) you see my records always vary along these lines...which means its always a little bit of adjustment here and there...

Is there a possibility not to hard code the below features to the Macro itself, but in Cells..

Ex:
1. Lets say in some data I might have 3 sets of info Remember the Breakout 1 : Phone Fax and Mobile
2. Some data I might have 2 sets of info Remember the Breakout 2 : Name and Designation
3. The Trilogy is connecting the both lol, you directed Breakout 3 :rofl: : Hoodies...
4. Number of cells I will have to highlight always equals to : sets of data by 2, ex: 1. 6, ex: 2. 4, and this ex: a 6 again...
5. Do you think you can manage to Direct Part 4 by doing something like this will say we make the Macro look into A1, B1, C1, D1, E1...If data available in any, the Data will be the Headers (A1:Phone B1:Fax C1:Mobile) etc...the rest completely depend on the number of headings and if no data is available with or without the header, make the header appear with "N/A"...

6. Do you think this is asking too much? Because in all 3 instances you managed to crack the case...
7. Then I can number the Function like Breakout - 1,2,3,4 and leave the rest for the Macro to do... (Then when there are 2 similar scenarios in One Sheet I can change a New Breakout Number with A2, B2, C2, D2, E2....etc...

Thank you again... Sorry for all the Trouble I have given you... Trust me I have been :banghead: for past few weeks now...

Quote:

---

Originally Posted by Paul_Hossler

Read through a macro and hit F1 to get the help on any unfamiliar terms, but many times you can make a fairly good guess

For example, "Replace" replaces something, "Split" splits something, etc.

---

You know bro, I opened up your VBA and tried to figure out the result area and hoping it will work, tried adding N/A and stuff :devil2: :dunno :banghead:...only to realize it was debugging and excel started to Freeze... I was in a mess... lol...then you just coded this massive macro... I feel sorry for myself...

Actually, I sort of expected it

Try this in the attachment

The WS Data col A is a list of words to be deleted (like pcs and Nos) is you want

The other columns are the list of key words. The UDF will take the input string, get any data associated with any keywords and construct the output string


Attachment 19039

Code:

---

Option Explicit

Sub drv()
   
    MsgBox BreakOutAll("Green Hoodie: 10 Black Hoodie: -", Worksheets("Data").Columns(2), Worksheets("Data").Columns(1))
    MsgBox BreakOutAll("Green Hoodie: 10pcs Black Hoodie: -", Worksheets("Data").Columns(2), Worksheets("Data").Columns(1))

    MsgBox BreakOutAll("Phone: 51-83-9498756, 5583772359 Fax: 61-88-4932516", Worksheets("Data").Columns(3))
    MsgBox BreakOutAll("Phone: 51-6785239556 Fax: 31-13-45225335 Mobile: -", Worksheets("Data").Columns(3))
    MsgBox BreakOutAll("Contact Person: James Anderson Designation: Proprietor", Worksheets("Data").Columns(4))
    MsgBox BreakOutAll("Contact Person: Gordan, David Designation: Seller Things", Worksheets("Data").Columns(4))
    MsgBox BreakOutAll("Contact Person: David Cameron Miller Designation: Vice President", Worksheets("Data").Columns(4))

End Sub

'
Function BreakOutAll(s As String, KeyWords As Range, Optional Exceptions As Range = Nothing) As String
    Dim i As Long, nStart As Long, j As Long
    Dim s1 As String, s2 As String
    Dim aOut() As String
    Dim r1 As Range, x1 As Range
    Dim v As Variant, v1 As Variant
   
   
    Application.Volatile
   
    Set r1 = KeyWords.Columns(1)
    Set r1 = r1.Cells(1, 1)
    Set r1 = Range(r1, r1.End(xlDown))
   
    If Exceptions Is Nothing Then
        Set x1 = Nothing
    Else
        Set x1 = Exceptions.Columns(1)
        Set x1 = x1.Cells(1, 1)
        Set x1 = Range(x1, x1.End(xlDown))
        If x1.Rows.Count = x1.Parent.Rows.Count Then Set x1 = Nothing
    End If
   
    ReDim aOut(1 To r1.Rows.Count, 1 To 2)
   
    'store key words, replacing space with chr(3)
    For i = LBound(aOut, 1) To UBound(aOut, 1)
        aOut(i, 1) = r1.Cells(i, 1).Value
        aOut(i, 1) = Replace(aOut(i, 1), " ", Chr(3))
        aOut(i, 2) = "N/A"
    Next I
   
    'get rid of multiple spaces
    s1 = s
    Do While InStr(s1, "  ") > 0
        s1 = Replace(s1, "  ", " ")
        s1 = Trim(s1)
    Loop
   
   
    'handle multiple data in single keyword (e.g. Phone: 999888777, 111222333) to keep together
    s1 = Replace(s1, ", ", Chr(1))
   
    'go through list of all possible keywords and put Chr(2) in front if space
    For i = LBound(aOut, 1) To UBound(aOut, 1)
        nStart = InStr(s1, " " & aOut(i, 1))
       
        'if keyword is there, ...
        If nStart > 0 Then
            Mid(s1, nStart, 1) = Chr(2)
        End If
       
    Next I
   
    'make " " = Chr(3)
    s1 = Replace(s1, " ", Chr(3))

    'Original  where a _ represents a space
    'Contact_Person:_Gordan,_David_Designation:_Seller_Things
   
    'Replaced where  1=comma+space, 2=space+keyfield, 3=space
    'Contact3Person:3Gordan1David2Designation:3Seller3Things
    '          1        2        3        4        5
    '1234567890123456789012345678901234567890123456789012345
    v = Split(s1, Chr(2))
   
    'v(0)
    'Contact3Person:3Gordan1David
    'v(1)
    'Designation:3Seller3Things
    For j = LBound(v) To UBound(v)
        v1 = Split(v(j), ":" & Chr(3))
        'v1(0)
        'Contact3Person
        'v1(1)
        'Gordan1David

        'go through list of all possible keywords
        For i = LBound(aOut, 1) To UBound(aOut, 1)
            If UCase(aOut(i, 1)) = UCase(v1(0)) Then
                aOut(i, 2) = v1(1)
                'if it's a dash, make N/A again
                If aOut(i, 2) = "-" Then aOut(i, 2) = "N/A"
            End If
        Next I
    Next j
   
    'if ther are Exceptions, replace exception list in all data
    If Not x1 Is Nothing Then
        For i = LBound(aOut, 1) To UBound(aOut, 1)
            If aOut(i, 2) <> "N/A" Then
                If Not IsNumeric(aOut(i, 2)) Then
                    For j = 1 To x1.Rows.Count
                        aOut(i, 2) = Replace(aOut(i, 2), x1.Cells(i, 1), vbNullString, 1, -1, vbTextCompare)
                    Next j
                End If
            End If
        Next I
    End If
    'fix strings by removing markers
    For i = LBound(aOut, 1) To UBound(aOut, 1)
        aOut(i, 1) = Replace(aOut(i, 1), Chr(3), " ")
        aOut(i, 1) = Replace(aOut(i, 1), Chr(1), ", ")
        aOut(i, 2) = Replace(aOut(i, 2), Chr(3), " ")
        aOut(i, 2) = Replace(aOut(i, 2), Chr(1), ", ")
    Next i
 
    'build the string
    s1 = vbNullString
    For i = LBound(aOut, 1) To UBound(aOut, 1)
        s1 = s1 & aOut(i, 1) & ": " & aOut(i, 2) & IIf(i < UBound(aOut, 1), " ", vbNullString)
    Next I
   
    'put back the ", "
    BreakOutAll = Trim(Replace(s1, Chr(1), ", "))
End Function

---