VBA remove text after :

[jenny1013]

Hello,

I have a worksheet where I need to separate out items into different columns and remove the text after ":"
The list looks like this
Breakfast: Eggs, Sausage, Toast; Lunch: Pizza, Tacos, Sandwich; Dinner: Salad, Steak
The main items (Breakfast, Lunch, Dinner) go into three different columns but the text after : needs to be deleted. I've inherited a macro that will among other things break them up into columns. (Parse the progress column is the section I'm working on. )

Sub Topic()

'

' Topic Translator Macro



'



'Parse the Bill Column

    Range("D2:D15000").Select

    Selection.TextToColumns Destination:=Range("D2:D15000"), DataType:=xlDelimited, _

        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _

        :=Array(1, 1), TrailingMinusNumbers:=True



'Parse the Progress Column

    Range("G2:G15000").Select

    Selection.TextToColumns Destination:=Range("G2:G15000"), DataType:=xlDelimited, _

        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _

        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _

        :=Array(1, 1), TrailingMinusNumbers:=True

     

'Remove the N/A values from the Bill Status fields

    Range("G2:G15000").Replace What:="N/A", _

        Replacement:=" ", LookAt:=xlPart, MatchCase:=False

     

'Replace any field with "Approved" to "Approved/Enacted"

    Dim c As Range

    Dim SrchRng

  

    Set SrchRng = ActiveSheet.Range("N2:N15000")

    Do

        Set c = SrchRng.Find("Approved", LookIn:=xlValues)

        If Not c Is Nothing Then c.Cells.Value = "DOGGIE"

    Loop While Not c Is Nothing

 

    Dim c2 As Range

    Dim SrchRng2

  

    Set SrchRng2 = ActiveSheet.Range("N2:N15000")

    Do

        Set c2 = SrchRng2.Find("DOGGIE", LookIn:=xlValues)

        If Not c2 Is Nothing Then c2.Cells.Value = "Approved/Enacted"

    Loop While Not c2 Is Nothing

     

'Remove all "Hard Returns" from sheet

'    Dim s As String

   

'    On Error GoTo MyReplaceAbort

 

'    Application.DisplayStatusBar = True

'    Application.StatusBar = "Replacing Characters..."

'    Application.ScreenUpdating = False

 

'    For Each c In Range("A1:AA15000").Cells

'    c.Value = ReplaceCharacter(c.Value, Chr(10), " ")

'    Next c

 

'MyReplaceAbort:

 

'    Application.ScreenUpdating = True

'    Application.StatusBar = False

'    Application.DisplayStatusBar = True



End Sub

Thank you for any help!

 

[lrobbo314]

Here is a way using Power Query.

Book1
	A	B	C	D	E
1	Column1		Breaksfast	Lunch	Dinner
2	Breakfast: Eggs, Sausage, Toast; Lunch: Pizza, Tacos, Sandwich; Dinner: Salad, Steak		Eggs, Sausage, Toast	Pizza, Tacos, Sandwich	Salad, Steak
3	Breakfast: Waffles, Bacon, Hash Browns, Grits; Lunch: Hamburger, Chips, Pussing Cup, Fruit; Dinner: Pot Roast, Mashed Potatoes, Corn		Waffles, Bacon, Hash Browns, Grits	Hamburger, Chips, Pussing Cup, Fruit	Pot Roast, Mashed Potatoes, Corn
Sheet1

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Breakfast = Table.AddColumn(Table.TransformColumns(Source, {{"Column1", each Text.Split(_,"; ")}}), "Breaksfast", each Text.Split([Column1]{0},": "){1}),
    Lunch = Table.AddColumn(Breakfast, "Lunch", each Text.Split([Column1]{1},": "){1}),
    Dinner = Table.AddColumn(Lunch, "Dinner", each Text.Split([Column1]{2},": "){1}),
    RC = Table.RemoveColumns(Dinner,{"Column1"})
in
    RC

 

[lrobbo314]

This VBA will do the same thing.

Book1 (version 1) (version 1).xlsb
	A	B	C	D	E
1	Column1		Breakfast	Lunch	Dinner
2	Breakfast: Eggs, Sausage, Toast; Lunch: Pizza, Tacos, Sandwich; Dinner: Salad, Steak		Eggs, Sausage, Toast	Pizza, Tacos, Sandwich	Salad, Steak
3	Breakfast: Waffles, Bacon, Hash Browns, Grits; Lunch: Hamburger, Chips, Pussing Cup, Fruit; Dinner: Pot Roast, Mashed Potatoes, Corn		Waffles, Bacon, Hash Browns, Grits	Hamburger, Chips, Pussing Cup, Fruit	Pot Roast, Mashed Potatoes, Corn
Sheet5

Sub UNWIND()
Dim AR() As Variant: AR = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim MEAL() As String, ITEMS() As String, tmp As String

For i = LBound(AR) To UBound(AR)
    MEAL = Split(AR(i, 1), "; ")
    For j = LBound(MEAL) To UBound(MEAL)
        If j < UBound(MEAL) Then
            tmp = tmp & Split(MEAL(j), ": ")(1) & "*"
        Else
            tmp = tmp & Split(MEAL(j), ": ")(1)
        End If
    Next j
    AL.Add tmp
    tmp = vbNullString
Next i

With Range("C1:E1")
    .Value = Array("Breakfast", "Lunch", "Dinner")
    .Font.Bold = True
End With

With Range("C2").Resize(AL.Count, 1)
    .Value2 = Application.Transpose(AL.toArray)
    .TextToColumns DataType:=xlDelimited, Other:=True, otherchar:="*"
End With

End Sub

 

[Rick Rothstein]

Here is another macro that you can consider...

Sub BreakfastLunchDinner()
  Dim X As Long, Cell As Range, BLD() As String, Food() As String
  Range("C1:E1") = Array("Breakfast", "Lunch", "Dinner")
  Range("C1:E1").Font.Bold = True
  For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    BLD = Split(Cell, ";")
    For X = 0 To UBound(BLD)
      Cells(Cell.Row, "C").Offset(, X) = Trim(Split(BLD(X), ":")(1))
    Next
  Next
  Columns("C:E").AutoFit
End Sub

 

[jenny1013]

Sorry, I don't think I explained myself. The text after the : needs to be deleted. So their are a number of topics with subtopics. And I only need the topics in difference columns. There are also about 40+ topics.

Breakfast:Eggs, Sausage, Toast	Breakfast
Lunch: Sandwiches, Pizza; Dinner: Salad, Steak	Lunch	Dinner

Thank you

 

[Rick Rothstein]

Okay, then give this macro a try...

Sub GetTopics()
  Dim X As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(Rows.Count, "A").End(xlUp))
    Arr = Split(Cell.Value, ";")
    For X = 0 To UBound(Arr)
      Cell.Offset(, X + 1) = Split(Arr(X), ":")(0)
    Next
  Next
End Sub