Macro to transpose data from two columns into multiple rows

Solved with:

Sub test()
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 1).End(xlUp).Row - 1 To 1 Step -1
If Cells(i, "A") = Cells(i + 1, "A") Then
Cells(i, "B").NumberFormat = "@"
Cells(i, "B") = Cells(i, "B") & "/" & Cells(i + 1, "B")
Rows(i + 1).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub


Hi

I have the same problem as the following post, the only difference is that I have duplicate data in column2

example:

1 A
1 B
2 C
2 D
2 E
3 J
3 K
3 L
3 M
3M

The macro works but removes any duplicate data(i.e. only one 3M)

Thanks

Wolopter



I'm trying to copy a larger amount of data that is formatted in two columns. Column A has many repeated values. I need every cell in Column B that have the same value in A to be listed in one row.
I haven't been able to find an existing post that works for my data set, and I am not familiar enough with marcos to edit/trailor code already on the site to solve my problem.

An example of what the data is currently formatted like:

1 A
1 B
2 C
2 D
2 E
3 J
3 K
3 L
3 M

And I need it to look like this:

1 A B
2 C D E
3 J K L M

Does anyone have a Macro that could work for this?

Thanks in advance for the help


Last edited by Briansva92; 08-27-2012 at 09:32 PM.



Quick reply to this message Reply Reply With Quote Reply With Quote Multi-Quote This Message Add Reputation Report Post .

--------------------------------------------------------------------------------



08-27-2012, 10:47 PM
#2


xladept














xladept is offline
Forum Guru



xladept's Avatar

--------------------------------------------------------------------------------
Join Date:04-14-2012Location:Pasadena, CaliforniaMS-Off Ver:Excel 2003,2010Posts:3,653




Re: Macro to transpose data from two columns into multiple rows



Hi Briansva92,

Jindon wrote one of these the other day - I so admired the code that I saved it, here it is adapted to your example:



copy to clipboard
Sub Jindon()
Dim A, i As Long, e, x, y
With Range("a1").CurrentRegion
A = .Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(A, 1)
If Not .exists(A(i, 1)) Then
Set .Item(A(i, 1)) = _
CreateObject("Scripting.Dictionary")
End If
.Item(A(i, 1))(A(i, 2)) = Empty
Next
x = .keys: y = .items
End With
With .Offset(, .Columns.Count + 2).Cells(1)
.CurrentRegion.ClearContents
For i = 0 To UBound(x)
.Offset(i).Value = x(i)
.Offset(i, 1).Resize(, y(i).Count).Value = y(i).keys
Next
End With
End With
End Sub