Entering data into one string seperated by commas

[aherra23]

I joined two tables together.

First table is the item master table (the products we purchase)
Second table is the item location ( The location in which these items are set up to purchase)

Here is an example of the data

ITEM LOCATION
4280 03NSK
4280 01NSK
4280 03855Book1.xls
42800 57649
42800 02NSK
42800 57NSK
42800 03NSK
42800 67NSK
42800 65NSK
42800 01NSK
42800 91NSK
428000 67005
428001 15001
428001 15004
428001 15005
428002 57NSK
428002 57NBL
428003 57NBL
428003 57NSK


What I'd like to do is pull this data but instead of the data coming back in rows, I'd like it to appear as:

Item Location
4280 03855,01NSK,03NSK


ect..

 

[pboltonchina]

Try this on a copy of your data

Option Explicit


Sub Consolidate()
'JBeaucaire (9/18/2009)
'Columnar data is Sorted/Matched by column A values, merge all other cells into row format
Dim LastRow As Long, NextCol As Long
Dim LastCol As Long, Rw As Long, Cnt As Long
Dim DelRNG As Range
Application.ScreenUpdating = False


'Sort data
LastRow = Range("A" & Rows.count).End(xlUp).Row
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes

'Seed the delete range
Set DelRNG = Range("A" & LastRow + 10)

'Group matching names
For Rw = LastRow To 2 Step -1
If Cells(Rw, "A").Value = Cells(Rw - 1, "A").Value Then
Range(Cells(Rw, "B"), Cells(Rw, Columns.count).End(xlToLeft)).Copy _
Cells(Rw - 1, Columns.count).End(xlToLeft).Offset(0, 1)
Set DelRNG = Union(DelRNG, Range("A" & Rw))
End If
Next Rw


'Delete unneeded rows all at once
DelRNG.EntireRow.Delete (xlShiftUp)
Set DelRNG = Nothing


'Add titles
NextCol = Cells(1, Columns.count).End(xlToLeft).Column + 1
LastCol = Cells(1, 1).CurrentRegion.Columns.count
Range("B1", Cells(1, NextCol - 1)).Copy Range(Cells(1, NextCol), Cells(1, LastCol))


Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub