VBA remove text after :

jenny1013

New Member
Joined
Feb 12, 2018
Messages
7
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. )


VBA Code:
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!
 
Last edited by a moderator:

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Here is a way using Power Query.

Book1
ABCDE
1Column1BreaksfastLunchDinner
2Breakfast: Eggs, Sausage, Toast; Lunch: Pizza, Tacos, Sandwich; Dinner: Salad, SteakEggs, Sausage, ToastPizza, Tacos, SandwichSalad, Steak
3Breakfast: Waffles, Bacon, Hash Browns, Grits; Lunch: Hamburger, Chips, Pussing Cup, Fruit; Dinner: Pot Roast, Mashed Potatoes, CornWaffles, Bacon, Hash Browns, GritsHamburger, Chips, Pussing Cup, FruitPot Roast, Mashed Potatoes, Corn
Sheet1


Rich (BB code):
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
 
Upvote 0
This VBA will do the same thing.

Book1 (version 1) (version 1).xlsb
ABCDE
1Column1BreakfastLunchDinner
2Breakfast: Eggs, Sausage, Toast; Lunch: Pizza, Tacos, Sandwich; Dinner: Salad, SteakEggs, Sausage, ToastPizza, Tacos, SandwichSalad, Steak
3Breakfast: Waffles, Bacon, Hash Browns, Grits; Lunch: Hamburger, Chips, Pussing Cup, Fruit; Dinner: Pot Roast, Mashed Potatoes, CornWaffles, Bacon, Hash Browns, GritsHamburger, Chips, Pussing Cup, FruitPot Roast, Mashed Potatoes, Corn
Sheet5


VBA Code:
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
 
Upvote 0
Here is another macro that you can consider...
VBA Code:
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
 
Upvote 0
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, ToastBreakfast
Lunch: Sandwiches, Pizza; Dinner: Salad, SteakLunchDinner

Thank you
 
Upvote 0
Okay, then give this macro a try...
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top