Macro to compile a list with multiple columns

**plans** · 07-11-2015, 07:11 PM

Hello,
I have a list which contains three columns (see attached workbook).
I need a macro to generate a compiled list counting each item and list next to it the corresponding "Length" and "Width".
It has to be a macro, not formula or pivot table, because this is just a part of a more extensive routine.
Could anybody advise please?
Thank you

**protonLeah** · 07-11-2015, 09:02 PM

Sub ben()
    Dim LastRow     As Range, _
        ListItem    As Range, _
        Ndx As Long
        Ndx = 1
    
    Set LastRow = Cells(Rows.Count, "A").End(xlUp)
    
    For Each ListItem In Range("A2", LastRow)
        Err.Clear
        On Error Resume Next
        found = WorksheetFunction.Match(ListItem.Value, Range("E:E"), 0)
        
        If Err.Number > 0 Then  'unique found, so add
            Ndx = Ndx + 1
            Cells(Ndx, "E").Value = ListItem.Value
            Cells(Ndx, "F").Value = WorksheetFunction.CountIf(Range("A2", LastRow), ListItem)
            Cells(Ndx, "G").Resize(columnsize:=2).Value = ListItem.Offset(0, 1).Resize(columnsize:=2).Value
        End If
    Next ListItem
    Range("E1:H1").Value = Array("Item", "Each", "Length", "Width")
End Sub

**Ed_Collins** · 07-11-2015, 09:17 PM

Here's a quick and dirty solution. It temporarily uses the empty column D to keep track of which items in the list its already accounted for. (I mark the item with an "x" in column D.) Afterwards, I erase it, of course.

It seems to work as intended. It duplicates your intended output exactly. Modify as needed.

last_row = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Row = 1

For x = 2 To last_row
  If Cells(x, 4) <> "x" Then Row = Row + 1
  For y = x To last_row
    If Cells(x, 1) = Cells(y, 1) And Cells(y, 4) <> "x" Then
        Cells(y, 4) = "x"
        Cells(Row, 5) = Cells(x, 1)
        Cells(Row, 6) = Cells(Row, 6) + 1
        Cells(Row, 7) = Cells(x, 2)
        Cells(Row, 8) = Cells(x, 3)
    End If
 Next y
Next x

Range("D2:D" & last_row).Select
Selection.ClearContents
Range("A1").Select