Split text in a cell into multiple columns

[excelvbanoob420]

Hello,

I'm trying to solve a difficult problem of splitting data in a cell into multiple columns based on the number of items in that cell. Below is the sample data and I would like to split the data in Column3, Column4 and Column5 into multiple columns where each column contains an individual values based on text string 'FJ-SJ'. Any text with 'FJ-RJ' should be ignored in the split. This problem can better be understood by looking at the input and desired output shown below.

Input:

Column1	Column2	Column3	Column4	Column5
FJ-SJ-1111-1111	Randomtext1	FJ-SJ-0000-0101 FJ-RJ-0000-0010	FJ-SJ-0000-0102 FJ-SJ-0000-0103 FJ-SJ-0000-0104	FJ-SJ-0000-1111 FJ-RJ-0000-1111
FJ-SJ-1111-1112	Randomtext2	FJ-SJ-0000-0112 FJ-SJ-0000-0113 FJ-SJ-0000-0114	FJ-RJ-0000-0011 FJ-SJ-0000-0106 FJ-SJ-0000-0105	FJ-SJ-0000-1112 FJ-SJ-0000-1113 FJ-SJ-0000-1114
FJ-SJ-1111-1113	Randomtext3	FJ-RJ-0000-0011 FJ-RJ-0000-0012 FJ-SJ-0000-0115 FJ-SJ-0000-0116 FJ-SJ-0000-0117	FJ-RJ-0000-0011 FJ-RJ-0000-0012 FJ-SJ-0000-0107 FJ-SJ-0000-0108	FJ-RJ-0000-1112 FJ-SJ-0000-1115 FJ-SJ-0000-1116 FJ-SJ-0000-1117
FJ-SJ-1111-1114	Randomtext4	FJ-SJ-0000-0118 FJ-SJ-0000-0119	FJ-SJ-0000-0109	FJ-SJ-0000-1119

Output:

Column1

Column2

Column3

Column4

Column5

FJ-SJ-1111-1111

Randomtext1

FJ-SJ-0000-0101 FJ-RJ-0000-0010

FJ-SJ-0000-0101

FJ-SJ-0000-0102 FJ-SJ-0000-0103 FJ-SJ-0000-0104

FJ-SJ-0000-0102

FJ-SJ-0000-0103

FJ-SJ-0000-0104

FJ-SJ-0000-1111 FJ-RJ-0000-1111

FJ-SJ-0000-1111

FJ-SJ-1111-1112

Randomtext2

FJ-SJ-0000-0112 FJ-SJ-0000-0113 FJ-SJ-0000-0114

FJ-SJ-0000-0112

FJ-SJ-0000-0113

FJ-SJ-0000-0114

FJ-RJ-0000-0011 FJ-SJ-0000-0106 FJ-SJ-0000-0105

FJ-SJ-0000-0106

FJ-SJ-0000-0105

FJ-SJ-0000-1112 FJ-SJ-0000-1113 FJ-SJ-0000-1114

FJ-SJ-0000-1112

FJ-SJ-0000-1113

FJ-SJ-0000-1114

FJ-SJ-1111-1113

Randomtext3

FJ-RJ-0000-0011 FJ-RJ-0000-0012 FJ-SJ-0000-0115 FJ-SJ-0000-0116 FJ-SJ-0000-0117

FJ-SJ-0000-0115

FJ-SJ-0000-0116

FJ-SJ-0000-0117

FJ-RJ-0000-0011 FJ-RJ-0000-0012 FJ-SJ-0000-0107 FJ-SJ-0000-0108

FJ-SJ-0000-0107

FJ-SJ-0000-0108

FJ-RJ-0000-1112 FJ-SJ-0000-1115 FJ-SJ-0000-1116 FJ-SJ-0000-1117

FJ-SJ-0000-1115

FJ-SJ-0000-1116

FJ-SJ-0000-1117

FJ-SJ-1111-1114

Randomtext4

FJ-SJ-0000-0118 FJ-SJ-0000-0119

FJ-SJ-0000-0118

FJ-SJ-0000-0119

FJ-SJ-0000-0109

FJ-SJ-0000-0109

FJ-SJ-0000-1119

FJ-SJ-0000-1119

Any help i can get to solve this dynamic column creation problem will be highly appreciated.

 

[DanteAmor]

Here's a macro to consider.
The data on sheet1 starting at cell A2, the results will be displayed on sheet2 starting at cell A2.

Sub split_text()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, n As Long, lr As Long, lc As Long
  Dim fila As Long, col As Long, newcol As Long, maxcol As Long
  Dim dic As Object
  Dim bln As Boolean
  
  With Sheets("Sheet1")
    lc = .Cells(1, Columns.Count).End(1).Column
    lr = .Range("A1", .Cells(1, lc)).EntireColumn.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    a = .Range("A2", .Cells(lr, lc)).Value
    n = WorksheetFunction.CountIfs(.Range("C2", .Cells(lr, lc)), "*FJ-SJ*")
  End With
  ReDim b(1 To UBound(a, 1), 1 To n)
  Sheets("Sheet2").Cells.ClearContents
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a, 1)
    If a(i, 1) <> "" Then
      If Not dic.exists(a(i, 1)) Then
        dic(a(i, 1)) = i
      End If
    End If
    b(i, 1) = a(i, 1)
    b(i, 2) = a(i, 2)
  Next
  
  col = 3
  maxcol = col
  For j = 3 To UBound(a, 2)
    For i = 1 To UBound(a, 1)
      If dic.exists(a(i, 1)) Then
        fila = dic(a(i, 1))
        newcol = col + 1
      End If
      If Left(a(i, j), 5) = "FJ-SJ" Then
        b(fila, newcol) = a(i, j)
        newcol = newcol + 1
        If newcol > maxcol Then
          maxcol = newcol
          bln = True
        End If
      End If
      b(i, col) = a(i, j)
    Next
    If bln Then col = maxcol Else col = col + 1
    bln = False
  Next
  
  Sheets("Sheet2").Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[Anthony47]

@Fluff

what's wrong with the sample data the OP has already provided?

I was not able to determine if the data contain Chr(10) or the alignment is due to text wrapping. But in general it was not confirmed by the OP that the problem was solved

 

[DanteAmor]

I was not able to determine if the data contain Chr(10)

Your question made me know that the data is in a cell , when I copied and pasted the data it put them in different rows .

@excelvbanoob420 , I have to make adjustments to the macro and I'll post the updated macro.

 

[excelvbanoob420]

@Fluff

I was not able to determine if the data contain Chr(10) or the alignment is due to text wrapping. But in general it was not confirmed by the OP that the problem was solved

Spreadsheet uploaded, let me know if this helps?

Inputoutput

Input Column1,Column2,Column3,Column4,Column5 FJ-SJ-1111-1111,Randomtext1,FJ-SJ-0000-0101 FJ-RJ-0000-0010,FJ-SJ-0000-0102 FJ-SJ-0000-0103 FJ-SJ-0000-0104,FJ-SJ-0000-1111 FJ-RJ-0000-1111 FJ-SJ-1111-1112,Randomtext2,FJ-SJ-0000-0112 FJ-SJ-0000-0113 FJ-SJ-0000-0114,FJ-RJ-0000-0011 FJ-SJ-0000-0106 FJ...

docs.google.com

@DanteAmor

 

[DanteAmor]

Here the updated macro.
The data on sheet1 starting at cell A2, the results will be displayed on sheet2 starting at cell A2.

Please update the sheet names in these lines of the macros:

With Sheets("Sheet1")
...
With Sheets("Sheet2")

Try:

Sub split_text()
  Dim a As Variant, b As Variant, itm  As Variant
  Dim i As Long, j As Long, n As Long, lr As Long, lc As Long
  Dim col As Long, newcol As Long, maxcol As Long
  Dim bln As Boolean
  
  With Sheets("Sheet1")
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    lr = .Range("A1", .Cells(1, lc)).EntireColumn.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    a = .Range("A2", .Cells(lr, lc)).Value
    n = WorksheetFunction.CountIfs(.Range("C2", .Cells(lr, lc)), "*FJ-SJ*")
  End With
  ReDim b(1 To UBound(a, 1), 1 To n * 10)
  
  For i = 1 To UBound(a, 1)
    For j = 1 To 2
      b(i, j) = a(i, j)
    Next
  Next
  
  maxcol = 3
  col = 3
  For j = 3 To UBound(a, 2)
    For i = 1 To UBound(a, 1)
      
      b(i, col) = a(i, j)
      newcol = col
      For Each itm In Split(a(i, j), Chr(10))
        If Left(itm, 5) = "FJ-SJ" Then
          newcol = newcol + 1
          b(i, newcol) = itm
          If newcol > maxcol Then
            maxcol = newcol
            bln = True
          End If
        End If
      Next
      
    Next
    
    If bln Then col = maxcol + 1 Else col = col + 1
    bln = False
  Next
  
  With Sheets("Sheet2")
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    .Cells.EntireColumn.AutoFit
    .Cells.EntireRow.AutoFit
  End With
End Sub

 

[Anthony47]

Another option:

Sub Split420()
Dim oArr(), LastC As Long, LastR As Long
Dim mySplit, I As Long, J As Long, K As Long, hMax As Long, hInd As Long
Dim sSh As Worksheet, cCol As Long
'
Set sSh = Sheets("Sheet1")
sSh.Copy after:=sSh
LastC = Cells(1, Columns.Count).End(xlToLeft).Column
LastR = Cells(Rows.Count, 1).End(xlUp).Row
ReDim oArr(1 To LastR, 1 To 100)
cCol = 3
For I = cCol To LastC
    ReDim oArr(1 To LastR, 1 To 100)
    For J = 2 To LastR
        hInd = 0
        mySplit = Split(sSh.Cells(J, I) & Chr(10) & Chr(10), Chr(10), , vbTextCompare)
        For K = 0 To UBound(mySplit) - 2
            If InStr(1, mySplit(K), "FJ-RJ", vbTextCompare) = 0 Then
                hInd = hInd + 1
                oArr(J, hInd) = mySplit(K)
                If hInd > hMax Then hMax = hInd
            End If
        Next K
    Next J
    Cells(1, cCol + 1).Resize(1, hMax).EntireColumn.Insert
    Cells(1, cCol + 1).Resize(LastR, hMax).Value = oArr
    cCol = cCol + hMax + 1
Next I
End Sub

This will copy Sheet1 in a new sheet, then insert on this new sheet the splitted columns & values