This macro should do it for you. Change the Const values to match the sheet
names in your workbook once you paste the code in. I've set up 2 Const
values for them and 2 for the 2 columns involved on the source sheet.
To put the code to work: open the workbook, press [Alt]+[F11] to open the VB
Editor. In the VB Editor, choose Insert --> Module and then copy the code
below and paste it into the new code module. Make any edits to the Const
values that you need to and close the VB Editor.
Before running the macro, you should delete any old information (from row 2
on down the sheet) from it, otherwise the list just gets longer/wider each
time you run the macro. Run the macro from Excel's menu: Tools --> Macro -->
Macros and select this macro and click the [Run] button. You can run it from
any sheet in the workbook.
Sub GroupCustomersByPart()
'be sure to delete any previous results
'on the destination sheet before running
'this macro, otherwise you'll double the
'entries on it.
'change these const values as required
'for your workbook
Const sourceSheetName = "Sheet1"
Const pnColumn = "A" ' on source sheet
Const nameColumn = "L" ' on source sheet
Const destSheetName = "Sheet2"
Dim sourceWS As Worksheet
Dim sourcePNList As Range
Dim anySourcePN As Range
Dim destWS As Worksheet
Dim destPNList As Range
Dim anyDestPN As Range
Dim usedPNumbers() As Variant
Dim LC As Long
Dim destRow As Long
Dim destCol As Long
Dim offset2Name As Integer
'prep work for the job
Set sourceWS = Worksheets(sourceSheetName)
Set sourcePNList = sourceWS. _
Range(pnColumn & "2:" & _
sourceWS.Range(pnColumn & Rows.Count).End(xlUp).Address)
Set destWS = Worksheets(destSheetName)
ReDim usedPNumbers(1 To 1)
offset2Name = Range(nameColumn & 1).Column - _
Range(pnColumn & 1).Column
'examine each part number on source sheet
Application.ScreenUpdating = False ' for better performance
For Each anySourcePN In sourcePNList
'have we seen this # before?
For LC = LBound(usedPNumbers) To UBound(usedPNumbers)
destRow = 0 ' reset
If anySourcePN = usedPNumbers(LC) Then
'have seen it before, find it on
'the destination sheet
Set destPNList = _
destWS.Range("A2:" & _
destWS.Range("A" & Rows.Count).End(xlUp).Address)
For Each anyDestPN In destPNList
If anySourcePN = anyDestPN Then
destRow = anyDestPN.Row
Exit For ' quit looking
End If
Next
End If
If destRow <> 0 Then
Exit For
End If
Next ' end LC loop
If destRow = 0 Then
'a new number, add it to
'dest sheet & remember row number
destRow = destWS.Range("A" & Rows.Count). _
End(xlUp).Row + 1
'add it to the array of found PNs
usedPNumbers(UBound(usedPNumbers)) = anySourcePN
'make room for next PN
ReDim Preserve usedPNumbers(LBound(usedPNumbers) To _
UBound(usedPNumbers) + 1)
End If
'we have a destRow value, put the
'information on the destination sheet
destWS.Range("A" & destRow) = anySourcePN
'add this name to the destination sheet
'find next empty column
destCol = destWS.Cells(destRow, Columns.Count). _
End(xlToLeft).Column + 1
destWS.Cells(destRow, destCol) = _
anySourcePN.Offset(0, offset2Name)
Next ' end anySourcePN loop
'housecleaning
Set sourcePNList = Nothing
Set sourceWS = Nothing
Set destPNList = Nothing
Set destWS = Nothing
MsgBox "Job Completed"
End Sub
