Change horizontal list to vertical list (imagine a layered transpose)

hrithik · Aug 22, 2014

Hi,

I have 2 columns (ID, Product Interest) in the below format

A B
0001 A; B; C; D
0002 A; B
0003 D
0004 A; B; D; E

";" is the delimiter

I'm trying to come up with a macro to convert this data into this format:
A B
0001 A
0001 B
0001 C
0001 D
0002 A
0002 B
0003 D
0004 A
0004 B
0004 D
0004 E

I have been trying to get this work all morning but couldn't. Please help!

Thanks,

MickG · Aug 22, 2014

Try this:-
Results "D & E"

Code:

[COLOR="Navy"]Sub[/COLOR] MG22Aug28
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Ray
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
c = 1
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Offset(, 1), "; ")
    Cells(c, "D").Resize(UBound(Sp) + 1) = Dn
    Cells(c, "E").Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
    c = c + UBound(Sp) + 1
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

hrithik · Aug 22, 2014

Thanks a lot Mick! this works like a charm....Thanks again!

MickG · Aug 23, 2014

You're welcome

hiker95 · Aug 23, 2014

hrithik,

I had the following macro ready to go earlier (using two arrays in memory), but, I had to go out.

I see that MickG provided you with a solution.

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:

Sub ReorgData()
' hiker95, 08/23/2014, ME800829
Dim r As Long, lr As Long, n As Long, s, k As Long
Dim a As Variant, o As Variant
Dim i As Long, j As Long, c As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = Range("A1:B" & lr)
For Each c In Range("B1:B" & lr)
  n = n + Len(c) - Len(WorksheetFunction.Substitute(c, ";", "")) + 2
Next c
ReDim o(1 To n, 1 To 2)
For i = 1 To lr
  If InStr(a(i, 2), "; ") Then
    s = Split(a(i, 2), "; ")
    For k = LBound(s) To UBound(s)
      j = j + 1
      o(j, 1) = a(i, 1)
      o(j, 2) = s(k)
    Next k
  Else
    j = j + 1
    o(j, 1) = a(i, 1)
    o(j, 2) = a(i, 2)
  End If
Next i
Columns(4).Resize(, 2).ClearContents
Range("D1").Resize(n).NumberFormat = "@"
Range("D1").Resize(n, 2) = o
Columns(4).Resize(, 2).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 ReorgData macro.

Rick Rothstein · Aug 23, 2014

This can also be done without using a loop...

Code:

Sub RearrangeData()
  Dim LastRow As Long, Data() As String
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Data = Split(Join(Application.Transpose(Evaluate(Replace("IF(LEN(A1:A#),A1:A#&" & _
         """ ""&SUBSTITUTE(B1:B#,"";"","";""&A1:A#),"""")", "#", LastRow))), ";"), ";")
  With Range("D1").Resize(UBound(Data) + 1)
    .Value = Application.Transpose(Data)
    .TextToColumns Range("D1"), xlDelimited, , 0, 0, 0, 0, 1, 0, , Array(Array(1, 2), Array(2, 1))
  End With
End Sub

In case you are interested, here are the average times for each of the three code submissions posted so far to process 1000 rows of data on my (relatively fast) computer...

Rick: 0.03 seconds

hiker95: 0.03 seconds

Mick: 0.14 seconds

Rick Rothstein · Aug 23, 2014

Rick Rothstein said:
In case you are interested, here are the average times for each of the three code submissions posted so far to process 1000 rows of data on my (relatively fast) computer...

Rick: 0.03 seconds

hiker95: 0.03 seconds

Mick: 0.14 seconds

To follow up on this, here is a chart of times (in seconds) for 1000, 5000 and 10000 rows of original data...


	1000	5000	10000
hiker95	0.03	0.09	0.15
Rick	0.03	0.11	0.18
Mick	0.14	0.73	1.46

shg · Aug 23, 2014

I like hiker's code. I expect it would go a little faster if the counting were done on the memory array:

Code:

    For i = 1 To lr
        n = n + Len(a(i, 2)) - Len(Replace(a(1, 2), ";", "")) + 2
    Next i

hiker95 · Aug 23, 2014

shg,

I like hiker's code. I expect it would go a little faster if the counting were done on the memory array:

Thank you, thank you, thank you.

And, thanks for then new code idea concerning looping in the array.

MrExcel is a great place to learn new things.

hiker95 · Aug 23, 2014

shg,

I just tried your code change, and, it did not work correctly.

The following two changes did not work correctly:

Code:

For i = 1 To lr
  n = n + Len(a(i, 2)) - Len(Replace(a(1, 2), ";", "")) + 2
Next i

Code:

For i = 1 To lr
  n = n + Len(a(i, 2)) - Len(WorksheetFunction.Substitute(a(1, 2), ";", "")) + 2
Next i

Thank you again.

Change horizontal list to vertical list (imagine a layered transpose)

hrithik

Active Member

Excel Facts

MickG

MrExcel MVP

hrithik

Active Member

MickG

MrExcel MVP

hiker95

Well-known Member

Rick Rothstein

MrExcel MVP

Rick Rothstein

MrExcel MVP

shg

MrExcel MVP

hiker95

Well-known Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

Change horizontal list to vertical list (imagine a layered transpose)

Active Member

Excel Facts

MrExcel MVP

Active Member

MrExcel MVP

Well-known Member

MrExcel MVP

MrExcel MVP

MrExcel MVP

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock