Splitting an unknown number of strings into columns

SandsB

Well-known Member
Joined
Feb 13, 2007
Messages
609
I get data in column R that looks like this:
Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one.
Listing: Variable7, Here is yet another one, Variable12
Listing: Variable12

Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable1

Some (most) rows have nothing in column R. "Listing:" is sort of a heading and it only appears if there are variables. If there are no variables the cell is completely empty. When there's more than one variable, they're separated by commas. I know how to split up the data by using the commas. What I can't figure out is how to make each variable that's in the cell populate it's own column starting in row U. So with the examples of the 5 rows above (one is blank) column U would have a header of "Variable 1" and rows 1 and 5 would have a 1 in them. Column V would have a heading that says "Another Variable" and rows 1 and 5 would have a 1 in that column. Column W would have a heading that says "Here is yet another one" and rows 1 and 2 would have a 1. Etc. To make it more interesting, new variables could be added in the future so I'd need the macro to create headers based on what's in the file's list of variables, not a finite list that I know in advance.

There could be as many as 10 variables, separated by commas, in a cell of the original data. After adding the new columns, column R can be deleted. I can do that in the macro - just not the part that requires intelligence.
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Check if the following helps you, first you must put the name of the variables in the cells of row 1.

varios 29jun2020.xlsm
RUVWXY
1Variable1Another VariableHere is yet another oneVariable12Last one
2Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one11111
3Listing: Variable7, Here is yet another one, Variable12  11 
4Listing: Variable12   1 
5     
6Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable111   
Hoja8 (2)
Cell Formulas
RangeFormula
U2:Y6U2=IF(ISNUMBER(SEARCH(","&SUBSTITUTE(U$1," ",",")&",",SUBSTITUTE(","&$R2&","," ",","))),1,"")
 

SandsB

Well-known Member
Joined
Feb 13, 2007
Messages
609
Thanks but new variables could be added later with nobody telling me so I need a macro that creates headers based on what's in the file's list of variables, not a finite list that I know in advance. If I did it this way, new things could be added later and I wouldn't know about it.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Try this:

VBA Code:
Sub Splitting_columns()
  Dim a As Variant, b As Variant, vrb As Variant
  Dim c As String, d As String, dic As Object
  Dim i As Long, j As Long, k As Long, lr As Long, mx As Long
  
  lr = Range("R" & Rows.Count).End(3).Row
  a = Range("R2:R" & lr).Value2
  mx = Evaluate("=SUM(LEN(R2:R" & lr & ")-LEN(SUBSTITUTE(R2:R" & lr & ","","","""")))") + UBound(a, 1)
  ReDim b(1 To UBound(a, 1), 1 To mx)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  
  For i = 1 To UBound(a)
    c = Replace(a(i, 1), "Listing:", "", , , vbTextCompare)
    For Each vrb In Split(c, ",")
      d = WorksheetFunction.Trim(vrb)
      If Not dic.exists(d) Then
        k = k + 1
        dic(d) = k
      End If
      j = dic(d)
      b(i, j) = 1
    Next
  Next
  
  Range("U1").Resize(1, dic.Count).Value = dic.keys
  Range("U2").Resize(UBound(b, 1), dic.Count).Value = b
End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,779
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

If this does not do what you want, then post a screen shot or a XL2BB image of what you have in column R and what you expect to see in columns U thru ?,

VBA Code:
Sub t()
Dim c As Range, i As Long, fn As Range, rng As Range, spl As Variant, col As Long
With ActiveSheet
    Set rng = .Range("R2", .Cells(Rows.Count, 18).End(xlUp))
        For Each c In rng
            spl = Split(Mid(c.Value, InStr(c.Value, ":") + 2), ",")
            For i = LBound(spl) To UBound(spl)
                If .Range("U1") = "" Then
                    .Range("U1") = Trim(spl(i))
                    .Cells(Rows.Count, 21).End(xlUp)(2) = 1
                ElseIf Application.CountIf(Range("U1").Resize(, 300), spl(i)) = 0 Then
                    col = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
                    .Cells(1, col) = Trim(spl(i))
                    .Cells(Rows.Count, col).End(xlUp)(2) = 1
                Else
                    Set fn = .Range("U1").Resize(, 300).Find(Trim(spl(i)), , xlValues, xlWhole)
                        If Not fn Is Nothing Then
                            .Cells(Rows.Count, fn.Column).End(xlUp)(2) = 1
                        End If
                End If
            Next
        Next
End With
End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,779
Office Version
  1. 2013
Platform
  1. Windows
This mod will put the 1 on the correct row.
VBA Code:
Sub t2()
Dim c As Range, i As Long, fn As Range, rng As Range, spl As Variant, col As Long
With ActiveSheet
    Set rng = .Range("R2", .Cells(Rows.Count, 18).End(xlUp))
        For Each c In rng
            spl = Split(Mid(c.Value, InStr(c.Value, ":") + 2), ",")
            For i = LBound(spl) To UBound(spl)
                If .Range("U1") = "" Then
                    .Range("U1") = Trim(spl(i))
                    .Cells(c.Row, 21) = 1
                ElseIf Application.CountIf(Range("U1").Resize(, 300), spl(i)) = 0 Then
                    col = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
                    .Cells(1, col) = Trim(spl(i))
                    .Cells(c.Row, col) = 1
                Else
                    Set fn = .Range("U1").Resize(, 300).Find(Trim(spl(i)), , xlValues, xlWhole)
                        If Not fn Is Nothing Then
                            .Cells(c.Row, fn.Column) = 1
                        End If
                End If
            Next
        Next
End With
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

This mod will put the 1 on the correct row.
Hi JLGWhiz, your code is generating more columns for me.

varios 29jun2020.xlsm
RUVWXYZAAABACADAE
1Variable1Another VariableHere is yet another oneVariable12Last oneVariable7Here is yet another onevariable12Another VariableNew variable nobody ever saw beforeVariable1
2Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one11111
3Listing: Variable7, Here is yet another one, variable12111
4Listing: Variable121
5
6Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable11111
Hoja8


Column V would have a heading that says "Another Variable" and rows 1 and 5 would have a 1 in that column.
According to the OP in column V there should be 1 in rows 1 and 5.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
varios 29jun2020.xlsm
RUVWXYZAA
1Variable1Another VariableHere is yet another oneVariable12Last oneVariable7New variable nobody ever saw before
2Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one11111
3Listing: Variable7, Here is yet another one, variable12111
4Listing: Variable121
5
6Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable1111
Hoja8

Hope the above is what you need.

Here is a reduced version of my macro.
VBA Code:
Sub Splitting_columns()
  Dim a As Variant, b As Variant, vrb As Variant
  Dim c As String, d As String, dic As Object
  Dim i As Long, mx As Long
 
  With Range("R2", Range("R" & Rows.Count).End(3))
    a = .Value2
    mx = Evaluate("=SUM(LEN(" & .Address & ")-LEN(SUBSTITUTE(" & .Address & ","","","""")))")
  End With
  ReDim b(1 To UBound(a, 1), 1 To mx + UBound(a, 1))
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
 
  For i = 1 To UBound(a)
    c = Replace(a(i, 1), "Listing:", "", , , vbTextCompare)
    For Each vrb In Split(c, ",")
      d = Trim(vrb)
      If Not dic.exists(d) Then dic(d) = dic.Count + 1
      b(i, dic(d)) = 1
    Next
  Next
 
  Range("U1").Resize(1, dic.Count).Value = dic.keys
  Range("U2").Resize(UBound(b, 1), dic.Count).Value = b
End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,779
Office Version
  1. 2013
Platform
  1. Windows
Thanks @DanteAmor, missed a Trim and an If statement for the blank cells. This should now be OK.
BTW, I think the Rows 1 and 5 = 1 was a typo. Should have been rows 1 and 6 = 1 since row 5 was blank.
VBA Code:
Sub t3()
Dim c As Range, i As Long, fn As Range, rng As Range, spl As Variant, col As Long
With ActiveSheet
    Set rng = .Range("R2", .Cells(Rows.Count, 18).End(xlUp))
        For Each c In rng
            If c <> "" Then
            spl = Split(Mid(c.Value, InStr(c.Value, ":") + 2), ",")
            For i = LBound(spl) To UBound(spl)
                If .Range("U1") = "" Then
                    .Range("U1") = Trim(spl(i))
                    .Cells(c.Row, 21) = 1
                ElseIf Application.CountIf(Range("U1").Resize(, 300), Trim(spl(i))) = 0 Then
                    col = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
                    .Cells(1, col) = Trim(spl(i))
                    .Cells(c.Row, col) = 1
                Else
                    Set fn = .Range("U1").Resize(, 300).Find(Trim(spl(i)), , xlValues, xlWhole)
                        If Not fn Is Nothing Then
                            .Cells(c.Row, fn.Column) = 1
                        End If
                End If
            Next
            End If
        Next
End With
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,119,221
Messages
5,576,821
Members
412,748
Latest member
MikeyP14
Top