I have a spreadsheet example below:
Device Name App Owner
King 123 Brown
Queen 567 Orange
Bishop 789 Black
Knight 765 Red
King 321 Purple
King 987 Brown
Knight 456 Red
Total 7
Device Name only should be listed once, and the multiple App & Mgr
fileds need to be merged into one cell.
Need it to look like this:
Device Name App Owner
King 123, 321,987 Brown, Purple
Queen 567 Orange
Bishop 789 Black
Knight 765, 456 Red
Total 4
Thanks in advance!!!!
It looks like the Owners should only be listed once, and I will assume that the App should only be listed once also.
You can do this with a VBA macro. See the macro comments for some assumptions. As written, the macro will run on the Active Sheeet (usually the one showing) and assumes the data is in A1:Cnn where nn is the number of rows.
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 UniqueDevices()
Dim vSrc As Variant, vRes() As String
Dim rDest As Range
Dim collDN As Collection, collAP As Collection, collOW As Collection
Dim vUniques()
Dim i As Long, j As Long
'Results destination (could be anywhere)
Set rDest = Range("E1")
'Assume Source table is in A1:Cn
vSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=3)
'Generate list of unique device names
Set collDN = New Collection
On Error Resume Next
For i = 1 To UBound(vSrc, 1)
collDN.Add Item:=CStr(vSrc(i, 1)), Key:=CStr(vSrc(i, 1))
Next i
On Error GoTo 0
'Dimension Results Array
ReDim vRes(1 To collDN.Count, 1 To 3)
'Populate first column
For i = 1 To collDN.Count
vRes(i, 1) = collDN(i)
Next i
'For each DN, get the unique list of Apps and Owners
For i = 1 To UBound(vRes, 1)
Set collAP = New Collection
Set collOW = New Collection
For j = 1 To UBound(vSrc, 1)
If vRes(i, 1) = vSrc(j, 1) Then
On Error Resume Next
collAP.Add Item:=CStr(vSrc(j, 2)), Key:=CStr(vSrc(j, 2))
collOW.Add Item:=CStr(vSrc(j, 3)), Key:=CStr(vSrc(j, 3))
On Error GoTo 0
End If
Next j
'Add Apps to results array
ReDim vUniques(1 To collAP.Count)
For j = 1 To collAP.Count
vUniques(j) = collAP(j)
Next j
vRes(i, 2) = Join(vUniques, ", ")
'add owners to results array
ReDim vUniques(1 To collOW.Count)
For j = 1 To collOW.Count
vUniques(j) = collOW(j)
Next j
vRes(i, 3) = Join(vUniques, ", ")
Next i
'Size destination
Application.ScreenUpdating = False
Set rDest = rDest.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2))
rDest.EntireColumn.Clear
rDest = vRes
rDest.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
============================
