Formula/Macro Question

[carl]

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.

 

[Ron Rosenfeld]

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

 

[Ron Rosenfeld]

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

 

[Don Guillett]

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).InsertRange("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

 

[Don Guillett]

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).InsertRange("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

 

[carl]

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

 

[carl]

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