Reverse of sorting in excel question

[Rebuckley]

Is there a way to change this sort in excel?

A B C D
XYZ 217 A 1001
XYZ 217 A 1002
XYZ 217 H 1003
XYZ 304 A 1004
XYZ 304 A 1005

to
A B C D
XYZ 217 A 1001, 1002
XYZ 217 H 1003
XYZ 304 A 1004, 1005 .....??

Thanks -

 

[Zathras]

This code assumes you have data in the "standard" database format: First row headings, blank row at bottom, blank column at right, starting in col "A" or blank row at left, starting in row "1" or blank row above headings.

It also assumes that every column except the last is looked at for the matching process and that the data to be collapsed is in the right-hand column.

Assuming all of those conditions are met, select any cell in the data area and run the macro to get the results you want.
[blue]

Option Explicit

Sub CollapseLastColumn()
Dim rngDatabase As Range
Dim rngCurrentRow As Range
Dim nColumns As Integer
Dim nRow As Long
Dim nRowsDeleted As Long

  Set rngDatabase = ActiveCell.CurrentRegion
  nColumns = rngDatabase.Columns.Count

[green]

  ' Assume first row is column headings
  ' Change to nRow = 1 if no headings.

[/color]

  nRow = 2
  While nRow < rngDatabase.Rows.Count
    Set rngCurrentRow = Intersect(rngDatabase, rngDatabase.Rows(nRow))
    If NextRowMatches(rngCurrentRow) Then
      CollapseNextRow rngCurrentRow
      nRowsDeleted = nRowsDeleted + 1
    Else
      nRow = nRow + 1
    End If
  Wend
  For nRow = 1 To nRowsDeleted
    rngCurrentRow.Offset(1, 0).Insert (xlDown)
  Next nRow
  Set rngCurrentRow = Nothing
  Set rngDatabase = Nothing
End Sub

Private Function NextRowMatches(CurrentRow As Range) As Boolean
Dim nCol As Integer
  NextRowMatches = True
  For nCol = 1 To CurrentRow.Cells.Count - 1
    If CurrentRow.Cells(1, nCol) <> CurrentRow.Cells(2, nCol) Then
      NextRowMatches = False
      Exit For
    End If
  Next nCol
End Function

Private Sub CollapseNextRow(CurrentRow As Range)
  With CurrentRow
    .Cells(1, .Cells.Count).Value = &quot;'&quot; & _
       .Cells(1, .Cells.Count).Text & &quot;, &quot; & _
       .Cells(2, .Cells.Count).Text
  CurrentRow.Offset(1, 0).Delete (xlUp)
  End With
End Sub

[/color]