split characters in one cell to columns and create new columns

[knotka]

I have a table and I need to split characters within a table in easy way

ID	q1	q2	q3
1	0301|0303|0307	07065|07567	090861|090862|090863|090864|090865|090867|090869
2	0301|0303|0307|0308	07565|07567|07569	090861|090862|090863|090864
3	0301|0302	07457|07458	090861|090862
4	0301|0302|0304|0309	07457|07458|07459	090861|090862|090863|090864|090865|090867|090870

<tbody>
</tbody>

it should become like this

ID	q1	q2	q3
1	0301	07065	090861
1	0303	07567	090862
1	0307		090863
1			090864
1			090865
1			090867
1			090869
2	0301	07565	090861
2	0303	07567	090862
2	0307	07569	090863
2	0308		090864
3	0301	07457	090861
3	0302	07458	090862
4	0301	07457	090861

<tbody>
</tbody>

and so on

Please advice the easy way!
Many thanks

 

[knotka]

You're welcome - thanks for the feedback.

If you need to handle a lot more columns, my setup may scale more easily than Rick's.
Regarding the size of the code, I think that is largely due to spacing and comments.

Rick's version correctly adjusted for leading zero's though, and mine did not.
Below is an amendment to my version for a similar result:

Sub example()

    Dim vArr        As Variant
    Dim vOut        As Variant
    Dim v           As Variant
    Dim inpRow      As Long
    Dim inpCol      As Long
    Dim k           As Long
    Dim m           As Long
    Dim n           As Long

    ' get input data from Sheet1
    vArr = Sheet1.Range("A2:Z100").Value2
    ' initialise the output array
    ' (change 50000 to a bigger number
    ' if more output rows are expected)
    ReDim vOut(1 To 50000, 1 To UBound(vArr, 2))
    
    ' build the ouput array
    For inpRow = 1 To UBound(vArr, 1)
        ' store the starting output row - 1
        ' for the current input row
        n = n + m
        m = 0
        For inpCol = 2 To UBound(vArr, 2)
            k = 0
            For Each v In Split(vArr(inpRow, inpCol), "|")
                k = k + 1
                vOut(n + k, 1) = vArr(inpRow, 1)
                vOut(n + k, inpCol) = v
            Next v
            ' store the size of the
            ' cell with most delimiters
            ' for the current input row
            m = Application.Max(m, k)
        Next inpCol
    Next inpRow
    
    ' print output to Sheet2
    With Sheet2.Range("A2").Resize(UBound(vOut, 1), _
                                   UBound(vOut, 2))
        .NumberFormat = "@"
        .Value2 = vOut
    End With

End Sub

Adjusting the range as appropriate for your actual data set should allow this to scale easily for more rows and columns.
(You can also increase the output array size if required - i.e if you expect the output to result in more than 50000 rows, just change it to 100000 for example or something larger).

oh many thanks! This what I'm actually trying to do now. Ricks code I already understand but it's not working for bigger cells and columns, oh I just changing it's incorrectly. So I'll try yours

xx

 

[hiker95]

knotka,

The following macro will work for a varying number of rows and columns.

Sample raw data:

Excel 2007
	A	B	C	D	E	F
1	ID	q1	q2	q3	q4
2	1	0301|0302|0303	07065|07566	090861|090862|090863|090864|090865|090867|090869	090887|090888
3	2	0305|0306|0307|0308	07568|07569|07570	090871|090872|090873|090874	090890|090891|090892
4	3	0310|0311	07457|07458	090876|090877	090894
5	4	0313|0314|0315|0316	07460|07461|07462	090879	090896|090897|090898|090899
6
Sheet1

After the macro:

Excel 2007
	A	B	C	D	E	F
1	ID	q1	q2	q3	q4
2	1	0301	07065	090861	090887
3	1	0302	07566	090862	090888
4	1	0303		090863
5	1			090864
6	1			090865
7	1			090867
8	1			090869
9	2	0305	07568	090871	090890
10	2	0306	07569	090872	090891
11	2	0307	07570	090873	090892
12	2	0308		090874
13	3	0310	07457	090876	090894
14	3	0311	07458	090877
15	4	0313	07460	090879	090896
16	4	0314	07461		090897
17	4	0315	07462		090898
18	4	0316			090899
19
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub ReorgDataPlus()
' hiker95, 09/27/2013
' http://www.mrexcel.com/forum/excel-questions/729272-split-characters-one-cell-columns-create-new-columns.html
Dim r As Long, lr As Long, lc As Long, c As Long
Dim n As Long, nmax As Long, s
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 2), Cells(lr, lc)).NumberFormat = "@"
For r = lr To 2 Step -1
  nmax = 0
  For c = 2 To lc
    n = Len(Cells(r, c)) - Len(WorksheetFunction.Substitute(Cells(r, c), "|", ""))
    If n > nmax Then nmax = n
  Next c
  Rows(r + 1).Resize(nmax).Insert
  Range(Cells(r, 2), Cells(r + nmax, lc)).NumberFormat = "@"
  Cells(r + 1, 1).Resize(nmax).Value = Cells(r, 1).Value
  For c = 2 To lc
    n = Len(Cells(r, c)) - Len(WorksheetFunction.Substitute(Cells(r, c), "|", ""))
    If n > 0 Then
      s = Split(Cells(r, c), "|")
      Cells(r, c).Resize(UBound(s) + 1).Value = Application.Transpose(s)
    End If
  Next c
Next r
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataPlus macro.

 

[hiker95]

knotka,

Please do not quote entire replies from your helper. When quoting follow these guidelines:
1. Quote ONLY if it is needed to add clarity or context for your reply. If so, then
2. Quote ONLY the specific part of the post that is relevant - - not the entire post.

This will keep thread clutter to a minimum and make the discussion easier to follow.

 

[Rick Rothstein]

Ricks code I already understand but it's not working for bigger cells and columns, oh I just changing it's incorrectly.

Use this color coded copy of my function as a reference (see comments after the code)...

Sub SplitDataDown()
  Dim X As Long, Z As Long, I As Long, Index As Long, MaxUB As Long
  Dim Q1() As String, Q2() As String, Q3() As String
  Dim ArrIn As Variant, ArrOut As Variant
  Const MaxItemsPerCell As Long = 10
  ArrIn = Worksheets("Sheet1").Range("A2:D" & Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
  ReDim ArrOut(1 To MaxItemsPerCell * UBound(ArrIn), 1 To 4)
  For X = 1 To UBound(ArrIn)
    Q1 = Split(ArrIn(X, 2) & "|", "|")
    Q2 = Split(ArrIn(X, 3) & "|", "|")
    Q3 = Split(ArrIn(X, 4) & "|", "|")
    MaxUB = WorksheetFunction.Max(UBound(Q1), UBound(Q2), UBound(Q3))
    For Z = 0 To MaxUB
      Index = Index + 1
      ArrOut(Index, 1) = ArrIn(X, 1)
      If Z <= UBound(Q1) Then ArrOut(Index, 2) = CStr(Q1(Z))
      If Z <= UBound(Q2) Then ArrOut(Index, 3) = CStr(Q2(Z))
      If Z <= UBound(Q3) Then ArrOut(Index, 4) = CStr(Q3(Z))
    Next
  Next
  With Worksheets("Sheet2")
    .Range("A1:D1").Value = Worksheets("Sheet1").Range("A1:D1").Value
    .Range("A2:D" & UBound(ArrOut)).NumberFormat = "@"
    .Range("A2:D" & UBound(ArrOut)) = ArrOut
  End With
End Sub

I am guessing everything starts in cell A1... if so, then everything marked in red references the last column... the "D" letters are obvious changes whereas the 4 (column count) is tied to the last column and is easily overlooked.

 

[hiker95]

knotka,

With the same screenshots as my reply #12.

The below macro using two arrays in memory is much faster than my original macro..

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub ReorgDataArrays()
' hiker95, 09/27/2013
' http://www.mrexcel.com/forum/excel-questions/729272-split-characters-one-cell-columns-create-new-columns.html
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, iii As Long, ios As Long, ioe As Long
Dim r As Long, lr As Long, lc As Long, c As Long
Dim n As Long, nmax As Long, ntot As Long, s, ss As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 2), Cells(lr, lc)).NumberFormat = "@"
a = Range(Cells(2, 1), Cells(lr, lc))
For i = 1 To UBound(a, 1)
  nmax = 0
  For c = 2 To UBound(a, 2)
    n = Len(a(i, c)) - Len(WorksheetFunction.Substitute(a(i, c), "|", "")) + 1
    If n > nmax Then nmax = n
  Next c
  ntot = ntot + nmax
Next i
ReDim o(1 To ntot, 1 To UBound(a, 2))
ii = 1
For i = 1 To UBound(a, 1)
  nmax = 0
  For c = 2 To UBound(a, 2)
    n = Len(a(i, c)) - Len(WorksheetFunction.Substitute(a(i, c), "|", "")) + 1
    If n > nmax Then nmax = n
  Next c
  ios = ii
  ioe = ii + nmax - 1
  For iii = ios To ioe
    o(iii, 1) = a(i, 1)
  Next iii
  For c = 2 To UBound(a, 2)
    n = Len(a(i, c)) - Len(WorksheetFunction.Substitute(a(i, c), "|", "")) + 1
    If n > 0 Then
      s = Split(a(i, c), "|")
      ss = 0
      On Error Resume Next
      For iii = ios To ioe
        o(iii, c) = s(ss)
        ss = ss + 1
      Next iii
      On Error GoTo 0
    End If
  Next c
  ii = ioe + 1
Next i
Range("A2").Resize(UBound(o, 1), UBound(o, 2)).NumberFormat = "@"
Range("A2").Resize(UBound(o, 1), UBound(o, 2)) = o
Columns.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataArrays macro.