My data table looks like this:

Router Name
ABC QQQ
ABC SPY
ABC GOOG
EFG QQQ
EFG GOOG

I m trying to create this table:

Name Router
QQQ ABC,EFG
SPY ABC
GOOG ABC,EFG


Thanks in advance.

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

My data table looks like this:

Router Name
ABC QQQ
ABC SPY
ABC GOOG
EFG QQQ
EFG GOOG

I m trying to create this table:

Name Router
QQQ ABC,EFG
SPY ABC
GOOG ABC,EFG


Thanks in advance.

You can do it fairly easily with a macro.
This macro assumes your data is in columns A and B, and you want the results to start in column D. You may need to change the range assignments to suit.
It also assumes that router and name are in adjacent columns, and that router is in the leftmost column. Some code may need to be changed if this is not the case.

To enter this Macro (Sub), <alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8 opens the macro dialog box. Select the macro by name, and <RUN.

===============================
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

'set up results array
ReDim vResults(0 To 1, 1 To collName.Count)
For i = 1 To collName.Count
vResults(0, i) = collName(i)
Next i

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

'output results
Set rDest = rDest.Resize(rowsize:=UBound(vResults, 2), columnsize:=2)
rDest = WorksheetFunction.Transpose(vResults)

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

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
===============================

On Nov 11, 11:49*am, carl wrote:
My data table looks like this:

Router *Name
ABC * * QQQ
ABC * * SPY
ABC * * GOOG
EFG * * QQQ
EFG * * GOOG

I m trying to create this table:

Name * *Router
QQQ * * ABC,EFG
SPY * * ABC
GOOG * *ABC,EFG

Thanks in advance.

This does it
Sub lineemupSAS()Dim lr As LongDim lc As LongDim i As Mailer

Range("router").Copy Range("a1")lr = Cells(Rows.Count,
1).End(xlUp).RowColumns(2).CutColumns(1).InsertRan ge("A2:B" & lr).Sort
Key1:=Range("a2"), Order1:=xlAscending, _Header:=xlGuess,
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom* * *
**For i = lr To 1 Step -1If Cells(i + 1, 1) = Cells(i, 1) Then*lc =
Cells(i, Columns.Count).End(xlToLeft).Column + 1*Cells(i + 1, 2).Copy
Cells(i, lc)*Rows(i + 1).DeleteEnd IfNext iEnd Sub

On Nov 12, 8:29*am, Don Guillett wrote:
On Nov 11, 11:49*am, carl wrote:









My data table looks like this:

Router *Name
ABC * * QQQ
ABC * * SPY
ABC * * GOOG
EFG * * QQQ
EFG * * GOOG

I m trying to create this table:

Name * *Router
QQQ * * ABC,EFG
SPY * * ABC
GOOG * *ABC,EFG

Thanks in advance.

This does it
Sub lineemupSAS()Dim lr As LongDim lc As LongDim i As Mailer

Range("router").Copy Range("a1")lr = Cells(Rows.Count,
1).End(xlUp).RowColumns(2).CutColumns(1).InsertRan ge("A2:B" & lr).Sort
Key1:=Range("a2"), Order1:=xlAscending, _Header:=xlGuess,
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
**For i = lr To 1 Step -1If Cells(i + 1, 1) = Cells(i, 1) Then*lc =
Cells(i, Columns.Count).End(xlToLeft).Column + 1*Cells(i + 1, 2).Copy
Cells(i, lc)*Rows(i + 1).DeleteEnd IfNext iEnd Sub
word wrap fixed
==========
sub lineemupSAS()
Dim lr As Long
Dim lc As Long
Dim i As long

lr = Cells(Rows.Count, 1).End(xlUp).Row
Columns(2).CutColumns(1).Insert
Range("A2:B" & lr).Sort Key1:=Range("a2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
For i = lr To 1 Step -1
If Cells(i + 1, 1) = Cells(i, 1) Then
lc = Cells(i, Columns.Count).End(xlToLeft).Column + 1
Cells(i + 1, 2).Copy Cells(i, lc)
Rows(i + 1).Delete
End If
Next i
End Sub

On Nov 11, 4:52*pm, Ron Rosenfeld wrote:
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
===============================

thanks

On Nov 12, 9:34*am, Don Guillett wrote:
On Nov 12, 8:29*am, Don Guillett wrote:



On Nov 11, 11:49*am, carl wrote:

My data table looks like this:

Router *Name
ABC * * QQQ
ABC * * SPY
ABC * * GOOG
EFG * * QQQ
EFG * * GOOG

I m trying to create this table:

Name * *Router
QQQ * * ABC,EFG
SPY * * ABC
GOOG * *ABC,EFG

Thanks in advance.

This does it
Sub lineemupSAS()Dim lr As LongDim lc As LongDim i As Mailer

Range("router").Copy Range("a1")lr = Cells(Rows.Count,
1).End(xlUp).RowColumns(2).CutColumns(1).InsertRan ge("A2:B" & lr).Sort
Key1:=Range("a2"), Order1:=xlAscending, _Header:=xlGuess,
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
**For i = lr To 1 Step -1If Cells(i + 1, 1) = Cells(i, 1) Then*lc =
Cells(i, Columns.Count).End(xlToLeft).Column + 1*Cells(i + 1, 2).Copy
Cells(i, lc)*Rows(i + 1).DeleteEnd IfNext iEnd Sub

word wrap fixed
==========
sub lineemupSAS()
Dim lr As Long
Dim lc As Long
Dim i As long

lr = Cells(Rows.Count, 1).End(xlUp).Row
Columns(2).CutColumns(1).Insert
Range("A2:B" & lr).Sort Key1:=Range("a2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
For i = lr To 1 Step -1
If Cells(i + 1, 1) = Cells(i, 1) Then
*lc = Cells(i, Columns.Count).End(xlToLeft).Column + 1
*Cells(i + 1, 2).Copy Cells(i, lc)
*Rows(i + 1).Delete
End If
Next i
End Sub- Hide quoted text -

- Show quoted text -

thanks