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.

 

[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