How to Combine Grouped Records onto one row

[Lynn H via OfficeKB.com]

I have a spreadsheet that looks like this:
TYPE BIN KEY
BOOK ABC A513
BOOK ABC B134
BOOK DEF W222
BOOK DEF A678
BOOK DEF N890
BOOK DEF N333
BOOK XYZ D444
BOOK XYZ E555
BOOK XYZ F777

I want to be able to combine the records with same TYPE/BIN onto one row
putting the different keys into the same cell, like this:

TYPE BIN KEY
BOOK ABC A513, B134
BOOK DEF W222, A678, N890, N333
BOOK XYZ D444, E555, F777

Is there a way to do this?
Thanks,
Lynn


--
Message posted via http://www.officekb.com

[Rowan]

Lynn

Assuming your data starts in cell A1, save your book and then try this:

Sub MoveData()

Dim thisSht As Worksheet
Dim newSht As Worksheet
Dim Typ As String
Dim Bin As String
Dim Key As String
Dim TypBin As String
Dim ColA As Range
Dim Cell As Range
Dim endRow As Long
Dim fndCell As Range

Application.ScreenUpdating = False

Set thisSht = ActiveSheet
endRow = Cells(Rows.Count, 1).End(xlUp).Row
Set ColA = Range(Cells(2, 1), Cells(endRow, 1))

Set newSht = Sheets.Add

thisSht.Range("A1:C1").Copy Destination:=newSht.Range("B1:D1")
For Each Cell In ColA
Typ = Cell.Value
Bin = Cell.Offset(0, 1).Value
Key = Cell.Offset(0, 2).Value
TypBin = Typ & Bin
With newSht.Columns(1)
Set fndCell = .Find(TypBin, LookIn:=xlValues)
End With
If fndCell Is Nothing Then
With newSht
endRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
.Cells(endRow, 1).Value = TypBin
.Cells(endRow, 2).Value = Typ
.Cells(endRow, 3).Value = Bin
.Cells(endRow, 4).Value = Key
End With
Else
fndCell.Offset(0, 3).Value = fndCell.Offset(0, 3).Value _
& ", " & Key
End If
Next Cell

newSht.Cells(1, 1).EntireColumn.Delete

Application.ScreenUpdating = True

End Sub

Hope this helps
Rowan

"Lynn H via OfficeKB.com" wrote:

>
> I have a spreadsheet that looks like this:
> TYPE BIN KEY
> BOOK ABC A513
> BOOK ABC B134
> BOOK DEF W222
> BOOK DEF A678
> BOOK DEF N890
> BOOK DEF N333
> BOOK XYZ D444
> BOOK XYZ E555
> BOOK XYZ F777
>
> I want to be able to combine the records with same TYPE/BIN onto one row
> putting the different keys into the same cell, like this:
>
> TYPE BIN KEY
> BOOK ABC A513, B134
> BOOK DEF W222, A678, N890, N333
> BOOK XYZ D444, E555, F777
>
> Is there a way to do this?
> Thanks,
> Lynn
>
>
> --
> Message posted via http://www.officekb.com
>

[Lynn H via OfficeKB.com]

Thanks for your help Rowan, this does exactly what I need!

Lynn


Rowan wrote:
>Lynn
>
>Assuming your data starts in cell A1, save your book and then try this:
>
>Sub MoveData()
>
> Dim thisSht As Worksheet
> Dim newSht As Worksheet
> Dim Typ As String
> Dim Bin As String
> Dim Key As String
> Dim TypBin As String
> Dim ColA As Range
> Dim Cell As Range
> Dim endRow As Long
> Dim fndCell As Range
>
> Application.ScreenUpdating = False
>
> Set thisSht = ActiveSheet
> endRow = Cells(Rows.Count, 1).End(xlUp).Row
> Set ColA = Range(Cells(2, 1), Cells(endRow, 1))
>
> Set newSht = Sheets.Add
>
> thisSht.Range("A1:C1").Copy Destination:=newSht.Range("B1:D1")
> For Each Cell In ColA
> Typ = Cell.Value
> Bin = Cell.Offset(0, 1).Value
> Key = Cell.Offset(0, 2).Value
> TypBin = Typ & Bin
> With newSht.Columns(1)
> Set fndCell = .Find(TypBin, LookIn:=xlValues)
> End With
> If fndCell Is Nothing Then
> With newSht
> endRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
> .Cells(endRow, 1).Value = TypBin
> .Cells(endRow, 2).Value = Typ
> .Cells(endRow, 3).Value = Bin
> .Cells(endRow, 4).Value = Key
> End With
> Else
> fndCell.Offset(0, 3).Value = fndCell.Offset(0, 3).Value _
> & ", " & Key
> End If
> Next Cell
>
> newSht.Cells(1, 1).EntireColumn.Delete
>
> Application.ScreenUpdating = True
>
>End Sub
>
>Hope this helps
>Rowan
>
>> I have a spreadsheet that looks like this:
>> TYPE BIN KEY
>[quoted text clipped - 19 lines]
>> Thanks,
>> Lynn


--
Message posted via http://www.officekb.com