Splitting an unknown number of strings into columns

[SandsB]

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.

 

[DanteAmor]

Check if the following helps you, first you must put the name of the variables in the cells of row 1.

varios 29jun2020.xlsm
	R			U	V	W	X	Y
1				Variable1	Another Variable	Here is yet another one	Variable12	Last one
2	Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one			1	1	1	1	1
3	Listing: Variable7, Here is yet another one, Variable12					1	1
4	Listing: Variable12						1
5
6	Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable1			1	1
Hoja8 (2)

Cell Formulas
Range	Formula
U2:Y6	U2	=IF(ISNUMBER(SEARCH(","&SUBSTITUTE(U$1," ",",")&",",SUBSTITUTE(","&$R2&","," ",","))),1,"")

 

[SandsB]

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]

Try this:

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]

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 ?,

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]

This mod will put the 1 on the correct row.

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]

This mod will put the 1 on the correct row.

Hi JLGWhiz, your code is generating more columns for me.

varios 29jun2020.xlsm
	R			U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1				Variable1	Another Variable	Here is yet another one	Variable12	Last one	Variable7	Here is yet another one	variable12	Another Variable	New variable nobody ever saw before	Variable1
2	Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one			1	1	1	1	1
3	Listing: Variable7, Here is yet another one, variable12								1	1	1
4	Listing: Variable12						1
5
6	Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable1			1								1	1	1
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]

varios 29jun2020.xlsm
	R			U	V	W	X	Y	Z	AA
1				Variable1	Another Variable	Here is yet another one	Variable12	Last one	Variable7	New variable nobody ever saw before
2	Listing: Variable1, Another Variable, Here is yet another one, Variable12, Last one			1	1	1	1	1
3	Listing: Variable7, Here is yet another one, variable12					1	1		1
4	Listing: Variable12						1
5
6	Listing: Variable1, Another Variable, New variable nobody ever saw before, Variable1			1	1					1
Hoja8

Hope the above is what you need.

Here is a reduced version of my macro.

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]

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.

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