# Moving Data from Columns to Rows • ### Question

• Hello,

My question is how efficiently can I transpose data from a column to a row?

Column A contains the Item Number and Column B the Item name.

The same item can have several names because item number appears several times. My task is to organize the data in such a way that I would have only unique Item number and in next columns its' possible several names.

Data set looks like that:

Column A       Column B

1                     TT1

18                    TT18

22                    Y2

22                    U2

22                    KM2

24                    Y4

24                    U4

24                    KM4

124                  GS4

124                  GSF4

124                  FDG4

and so on...

So I would like to remove duplicates in item number column but have all possible item names next to it.

Something like that:

Column A       Column B          Column C     Column D      Column E

1                   TT1

18                 TT18

22                 Y2                      U2                KM2

24                 Y4                      U4                KM4

124               GS4                   GSF4             FDG4

So on...

Thank you!

Monday, December 21, 2015 9:46 AM

• Here is a macro you can run:

```Sub Transform()
Dim r As Long
Dim m As Long
Dim c As Long
Application.ScreenUpdating = False
m = Cells(Rows.Count, 1).End(xlUp).Row
c = 2
For r = m - 1 To 1 Step -1
If Cells(r + 1, 1).Value = Cells(r, 1).Value Then
Cells(r + 1, 2).Insert Shift:=xlShiftToRight
Cells(r + 1, 2).Value = Cells(r, 2).Value
Cells(r, 1).EntireRow.Delete
Else
c = 2
End If
Next r
Application.ScreenUpdating = True
End Sub```

Test on a copy of your worksheet first!

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Monday, December 21, 2015 6:03 PM
Monday, December 21, 2015 11:20 AM

### All replies

• Here is a macro you can run:

```Sub Transform()
Dim r As Long
Dim m As Long
Dim c As Long
Application.ScreenUpdating = False
m = Cells(Rows.Count, 1).End(xlUp).Row
c = 2
For r = m - 1 To 1 Step -1
If Cells(r + 1, 1).Value = Cells(r, 1).Value Then
Cells(r + 1, 2).Insert Shift:=xlShiftToRight
Cells(r + 1, 2).Value = Cells(r, 2).Value
Cells(r, 1).EntireRow.Delete
Else
c = 2
End If
Next r
Application.ScreenUpdating = True
End Sub```

Test on a copy of your worksheet first!

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Monday, December 21, 2015 6:03 PM
Monday, December 21, 2015 11:20 AM
• Thank you Hans,

It works perfectly! Good idea :-)

Best regards,

Gytis

Monday, December 21, 2015 6:04 PM