Moving duplicate row data into new columns

[welndmn]

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

Car_No	wheel	tire
100	17	BFG
100	16	Goodyear
100	15	BFG
101	17

<tbody>
</tbody>

And what I am hoping for

Car_no	Wheel	Wheel_2	Wheel_3	Tire_1	Tire_2	Tire_3
100	17	16	15	BFG	Goodyear	BFG
101	17

<tbody>
</tbody>

Any ideas?

 

[DanteAmor]

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:

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

 

[welndmn]

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?

 

[DanteAmor]

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.

 

[mohadin]

Hi
Try

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

 

[DanteAmor]

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?

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.

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

 

[mohadin]

Hi
Ignore the code in post#5
and please try

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