Moving duplicate row data into new columns

W

welndmn

New Member
Joined
Oct 22, 2013
Messages
31
Hello Everyone,

I'm having an issue where I can't even seem to find the right key words to search on.
I have data in a query that I've giving up on rewriting to split into columns, so I was hoping to see if anyone had some ideas on how to move the data into rows?
Here is a crude example of what I have
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Car_No[/TD]
[TD]wheel[/TD]
[TD]tire[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]17[/TD]
[TD]BFG[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]16[/TD]
[TD]Goodyear[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]15[/TD]
[TD]BFG[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]101[/TD]
[TD]17[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

And what I am hoping for
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Car_no[/TD]
[TD]Wheel[/TD]
[TD]Wheel_2[/TD]
[TD]Wheel_3[/TD]
[TD]Tire_1[/TD]
[TD]Tire_2[/TD]
[TD]Tire_3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]17[/TD]
[TD]16[/TD]
[TD]15[/TD]
[TD]BFG[/TD]
[TD]Goodyear[/TD]
[TD]BFG[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]101[/TD]
[TD]17[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Any ideas?
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
If the data starts at A1 the result will start at E1 as shown below:


<table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:57.98px;" /><col style="width:57.98px;" /><col style="width:85.54px;" /><col style="width:15.21px;" /><col style="width:57.98px;" /><col style="width:57.98px;" /><col style="width:57.98px;" /><col style="width:57.98px;" /><col style="width:57.98px;" /><col style="width:104.55px;" /><col style="width:57.98px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td><td >F</td><td >G</td><td >H</td><td >I</td><td >J</td><td >K</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Car_No</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Wheel</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Tire</td><td > </td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Car_No</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Wheel_1</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Wheel_2</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Wheel_3</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Tire_1</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Tire_2</td><td style="background-color:#ffff00; font-weight:bold; text-align:center; ">Tire_3</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td style="text-align:right; ">100</td><td style="text-align:right; ">12</td><td >BFG</td><td > </td><td style="text-align:right; ">100</td><td style="text-align:right; ">12</td><td style="text-align:right; ">13</td><td style="text-align:right; ">14</td><td >BFG</td><td >Goodyear</td><td >BFG</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td style="text-align:right; ">100</td><td style="text-align:right; ">13</td><td >Goodyear</td><td > </td><td style="text-align:right; ">101</td><td style="text-align:right; ">16</td><td style="text-align:right; ">17</td><td > </td><td >Mich</td><td >BFG</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td style="text-align:right; ">100</td><td style="text-align:right; ">14</td><td >BFG</td><td > </td><td style="text-align:right; ">102</td><td style="text-align:right; ">18</td><td > </td><td > </td><td >Ngh</td><td > </td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td style="text-align:right; ">101</td><td style="text-align:right; ">16</td><td >Mich</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td style="text-align:right; ">101</td><td style="text-align:right; ">17</td><td >BFG</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td style="text-align:right; ">102</td><td style="text-align:right; ">18</td><td >Ngh</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td></tr></table>

Use the following macro:


Code: 
Sub Moving_duplicate_row()
  Dim a() As Variant, dict As Variant, i As Long, it As Variant, m As Variant
  Dim b() As Variant, ant As Variant, j As Long, k As Long
  Range("E1", Cells(Rows.Count, Columns.Count)).ClearContents
[COLOR=#008000]  a = Range("A1:C" & Range("A" & Rows.Count).End(xlUp).Row).Value[/COLOR]
  Set dict = CreateObject("scripting.dictionary")
  For i = 1 To UBound(a)
    dict.Item(a(i, 1)) = dict.Item(a(i, 1)) + 1
  Next
  m = 0
  For Each it In dict.items
    If it > m Then m = it
  Next
  ReDim b(1 To dict.Count, 1 To (m * 2) + 1)
  ant = a(1, 1)
  k = 1
  For i = 1 To UBound(a)
    b(k, 1) = a(i, 1)
    For j = 2 To m + 1
      If i > UBound(a) Then Exit For
      If ant <> a(i, 1) Then Exit For
      b(1, j) = a(1, 2) & "_" & j - 1
      b(1, j + m) = a(1, 3) & "_" & j - 1
      b(k, j) = a(i, 2)
      b(k, j + m) = a(i, 3)
      i = i + 1
    Next
    If i > UBound(a) Then Exit For
    ant = a(i, 1)
    i = i - 1
    k = k + 1
  Next
[COLOR=#0000ff]  Range("E1").Resize(dict.Count, (m * 2) + 1).Value = b()[/COLOR]
End Sub
 
Upvote 0
That works, but I can't tell where it's limited to move only the 3 columns, I have more than that, can you show me?
 
Upvote 0
How many columns?
Is there a limit or can it grow over time?

You could put an example with 4 columns to understand what you mean.
 
Upvote 0
Hi
Try
Code: 
Sub test()
    Dim a As Variant, lr, i, x, s, k, itm, itmm
    Dim d As Object
    a = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 3)
    With CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                    d.Add a(i, 1), a(i, 3)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                    d.Item(a(i, 1)) = d.Item(a(i, 1)) & "," & a(i, 3)
                End If
            End If
        Next
        k = .keys
        itm = .items
               itmm = d.items
        s = 1
        Cells(1, 1).Offset(1, 3).Resize(.Count) = k
        For i = 1 To .Count
            x1 = Split(itm(i - 1), ",")
            x2 = Split(itmm(i - 1), ",")
            Cells(1, 1).Offset(i, 4).Resize(, UBound(x1) + 1) = x1
            Cells(1, 1).Offset(i, 4 + 3).Resize(, UBound(x2) + 1) = x2
        Next
    End With
End Sub
 
Last edited:
Upvote 0
welndmn said:
That works, but I can't tell where it's limited to move only the 3 columns, I have more than that, can you show me?
Click to expand...

How about. You can put the columns you want.

Start the data in cell A1 and after the last header leave a free column.
For example, if you have data up to column E, then leave column F free.

Code: 
Sub Moving_duplicate_row_2()
  Dim a() As Variant, dict As Variant, i As Long, it As Variant, m As Variant
  Dim b() As Variant, ant As Variant, j As Long, k As Long, r As Range, p As Long
  Set r = Range("[COLOR=#0000ff]A1[/COLOR]").CurrentRegion
  Range(r.Offset(, r.Columns.Count + 1).Cells(1, 1), Cells(Rows.Count, Columns.Count)).ClearContents
  a = r.Value
  Set dict = CreateObject("scripting.dictionary")
  For i = 1 To UBound(a)
    dict.Item(a(i, 1)) = dict.Item(a(i, 1)) + 1
  Next
  m = 0
  For Each it In dict.items
    If it > m Then m = it
  Next
  ReDim b(1 To dict.Count, 1 To (m * (r.Columns.Count - 1)) + 1)
  ant = a(1, 1)
  k = 1
  For i = 1 To UBound(a)
    b(k, 1) = a(i, 1)
    For j = 2 To m + 1
      If i > UBound(a) Then Exit For
      If ant <> a(i, 1) Then Exit For
      For p = 2 To r.Columns.Count '- 1
        b(1, j + (p - 2) * m) = a(1, p) & "_" & j - 1
        b(k, j + (p - 2) * m) = a(i, p)
      Next
      i = i + 1
    Next
    If i > UBound(a) Then Exit For
    ant = a(i, 1)
    i = i - 1
    k = k + 1
  Next
  r.Offset(, r.Columns.Count + 1).Cells(1, 1).Resize(dict.Count, (m * (r.Columns.Count - 1)) + 1).Value = b()
End Sub
 
Upvote 0
Hi
Ignore the code in post#5
and please try
Code: 
Sub test()
    Dim a As Variant, i, x1, k, z, itm, itmm
    Dim d As Object
    a = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 3)
    With CreateObject("scripting.dictionary")
        Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                    d.Add a(i, 1), a(i, 3)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                    d.Item(a(i, 1)) = d.Item(a(i, 1)) & "," & a(i, 3)
                End If
            End If
        Next
       itm = .items
        z = 0
        For i = 0 To .Count - 1
            x1 = Split(itm(i), ",")
            If UBound(x1) <> -1 And UBound(x1) > z Then
                z = UBound(x1)
            End If
        Next
        Application.DisplayAlerts = False
        Cells(1, 1).Offset(1, 3).Resize(d.Count) = Application.Transpose(.keys)
        Cells(1, 1).Offset(1, 4).Resize(.Count) = Application.Transpose(.items)
        Cells(1, 1).Offset(1, 5 + z).Resize(d.Count) = Application.Transpose(d.items)
        Cells(1, 1).Offset(1, 4).Resize(.Count).Resize(.Count).TextToColumns Destination:=Cells(1, 1).Offset(1, 4).Resize(.Count), Comma:=True, FieldInfo _
                                                                                                                                              :=Array(Array(1, 1))
        Cells(1, 1).Offset(1, 5 + z).Resize(d.Count).TextToColumns Destination:=Cells(1, 1).Offset(1, 5 + z).Resize(.Count), Comma:=True, FieldInfo _
                                                                                                                                        :=Array(Array(1, 1))
        Application.DisplayAlerts = True
    End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Transpose Data into multiple Columns
Replies
8
Views
313
kvsrinivasamurthy
K
S
  • Question Question
Inventory disposal plan
Replies
3
Views
302
Spaceballs_the_fanboy
S
A
  • Solved
Track movement stock in listbox on userform by copy amounts from previous row to next row
Replies
8
Views
105
abdo meghari
A
M
  • Question Question
Macro or Power Automate to Identify and Move "Washes" from the "Master" Sheet to the "Washes" Sheet
Replies
0
Views
192
Madam_Xavier
M
O
  • Solved
VBA - Filter columns, cut/paste rows new sheet, pivot table
2
Replies
12
Views
315
Skyybot
Skyybot

Forum statistics

Threads
1,224,819
Messages
6,181,153
Members
453,021
Latest member
Justyna P

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