On Fri, 11 Nov 2011 15:59:32 -0500, Ron Rosenfeld wrote:

On Fri, 11 Nov 2011 09:49:56 -0800 (PST), carl wrote:

Slightly simpler macro (doesn't need the tranpose before output of results):

======================
Option Explicit
Sub CreateTable()
Dim rRouter As Range, rName As Range, c As Range
Dim sFirstAddress As String
Dim rDest As Range
Dim vResults() As Variant
Dim i As Long
Dim collName As Collection
Set rRouter = Range("A1", Cells(Cells.Rows.Count, "A").End(xlUp))
Set rName = rRouter.Offset(columnoffset:=1)
Set rDest = Range("D1")

'Get Unique List of Names
Set collName = New Collection
On Error Resume Next
For Each c In rName
collName.Add Item:=c.Value, Key:=CStr(c.Text)
Next c
On Error GoTo 0
ReDim vResults(1 To collName.Count, 0 To 1)
For i = 1 To collName.Count
vResults(i, 0) = collName(i)
Next i

'Get routers associated with each name
For i = 2 To UBound(vResults, 1) 'i = 1 -- Label
With rName
Set c = .Find(what:=vResults(i, 0), LookIn:=xlValues, _
lookat:=xlWhole, MatchCase:=False)
sFirstAddress = c.Address
Do
vResults(i, 1) = vResults(i, 1) & "," & c.Offset(columnoffset:=-1).Value
Set c = .FindNext(after:=c)
Loop While Not c Is Nothing And c.Address < sFirstAddress
End With
vResults(i, 1) = Mid(vResults(i, 1), 2)
Next i
vResults(1, 1) = "Routers"

'Output results
Set rDest = rDest.Resize(rowsize:=UBound(vResults, 1), columnsize:=2)
rDest.EntireColumn.ClearContents
rDest = vResults

End Sub
===============================