split characters in one cell to columns and create new columns

K

knotka

New Member
Joined
Sep 26, 2013
Messages
6
I have a table and I need to split characters within a table in easy way
[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]q1[/TD]
[TD]q2[/TD]
[TD]q3[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]0301|0303|0307[/TD]
[TD]07065|07567[/TD]
[TD]090861|090862|090863|090864|090865|090867|090869[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0301|0303|0307|0308[/TD]
[TD]07565|07567|07569[/TD]
[TD]090861|090862|090863|090864[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0301|0302[/TD]
[TD]07457|07458[/TD]
[TD]090861|090862[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]0301|0302|0304|0309[/TD]
[TD]07457|07458|07459[/TD]
[TD]090861|090862|090863|090864|090865|090867|090870[/TD]
[/TR]
</tbody>[/TABLE]

it should become like this
[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]q1[/TD]
[TD]q2[/TD]
[TD]q3[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]0301[/TD]
[TD]07065[/TD]
[TD]090861[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]0303[/TD]
[TD]07567[/TD]
[TD]090862[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]0307[/TD]
[TD][/TD]
[TD]090863[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD]090864[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD]090865[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD]090867[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD]090869[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0301[/TD]
[TD]07565[/TD]
[TD]090861[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0303[/TD]
[TD]07567[/TD]
[TD]090862[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0307[/TD]
[TD]07569[/TD]
[TD]090863[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0308[/TD]
[TD][/TD]
[TD]090864[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0301[/TD]
[TD]07457[/TD]
[TD]090861[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0302[/TD]
[TD]07458[/TD]
[TD]090862[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]0301[/TD]
[TD]07457[/TD]
[TD]090861[/TD]
[/TR]
</tbody>[/TABLE]

and so on

Please advice the easy way!
Many thanks
 
Sort by date Sort by votes
circledchicken said:
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:

Code: 
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).
Click to expand...

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
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
knotka,

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

Sample raw data:


Excel 2007
ABCDEF
1IDq1q2q3q4
210301|0302|030307065|07566090861|090862|090863|090864|090865|090867|090869090887|090888
320305|0306|0307|030807568|07569|07570090871|090872|090873|090874090890|090891|090892
430310|031107457|07458090876|090877090894
540313|0314|0315|031607460|07461|07462090879090896|090897|090898|090899
6
Sheet1


After the macro:


Excel 2007
ABCDEF
1IDq1q2q3q4
21030107065090861090887
31030207566090862090888
410303090863
51090864
61090865
71090867
81090869
92030507568090871090890
102030607569090872090891
112030707570090873090892
1220308090874
133031007457090876090894
143031107458090877
154031307460090879090896
164031407461090897
174031507462090898
1840316090899
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).

Code: 
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.
 
Upvote 0
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.
 
Upvote 0
knotka said:
Ricks code I already understand but it's not working for bigger cells and columns, oh I just changing it's incorrectly.
Click to expand...
Use this color coded copy of my function as a reference (see comments after the code)...

Rich (BB 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.
 
Upvote 0
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).

Code: 
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.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

Share this page

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