Finding unique values and inserting them in the first row for each user occurance

hiker95 said:

techie2013,

With you raw data already sorted/grouped per your screenshot.

Sample raw data:

Excel 2007

	A	B	C	D
1	User	Permission	Permission Category
2	User1	trade stocks	buy-sell
3	User1	import items	buy
4	User1	issue orders	sell
5	User2	distribute items	sell
6	User2	issue bills	sell
7	User3	order items	buy
8	User3	request delivery	buy
9

<TBODY>
</TBODY>

Sheet1​

After the macro:

Excel 2007

	A	B	C	D
1	User	Permission	Permission Category	Unique Permission Categories
2	User1	trade stocks	buy-sell	buy-sell, buy, sell
3	User1	import items	buy
4	User1	issue orders	sell
5	User2	distribute items	sell	sell
6	User2	issue bills	sell
7	User3	order items	buy	buy
8	User3	request delivery	buy
9

<TBODY>
</TBODY>

Sheet1​

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Rich (BB code):

Option Explicit
Sub GetUniquePermissionCategories()
' hiker95, 01/03/2014
' http://www.mrexcel.com/forum/excel-questions/748181-finding-unique-values-inserting-them-first-row-each-user-occurance.html
Dim lr As Long, r As Long, n As Long, c As Range, rng As Range
Application.ScreenUpdating = False
Columns(4).ClearContents
Cells(1, 4) = "Unique Permission Categories"
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
  For r = 2 To lr
    n = Application.CountIf(Columns(1), Cells(r, 1).Value)
    If n = 1 Then
      Cells(r, 4) = Cells(r, 3)
    ElseIf n > 1 Then
      Set rng = Range("C" & r & ":C" & r + n - 1)
      For Each c In rng
        If c <> "" Then
          If Not .Exists(Trim(c.Value)) Then
            .Add c.Value, c.Value
          End If
        End If
      Next c
      Cells(r, 4) = Join(.Keys, ", ")
    End If
    r = r + n - 1
    .RemoveAll
  Next r
End With
Columns(4).AutoFit
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetUniquePermissionCategories macro.

Click to expand...

Option Explicit
Sub GetUniqueTemplateAM()
' hiker95, 01/03/2014
' [URL]http://www.mrexcel.com/forum/excel-questions/748181-finding-unique-values-inserting-them-first-row-each-user-occurance.html[/URL]
Dim lr As Long, r As Long, n As Long, c As Range, rng As Range
Application.ScreenUpdating = False
Columns(9).ClearContents
Cells(1, 9) = "Unique Template AM"
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
  For r = 2 To lr
    n = Application.CountIf(Columns(1), Cells(r, 1).Value)
    If n = 1 Then
      Cells(r, 9) = Cells(r, 8)
    ElseIf n > 1 Then
      Set rng = Range("H" & r & ":H" & r + n - 1)
      For Each c In rng
        If c <> "" Then
          If Not .Exists(Trim(c.Value)) Then
            .Add c.Value, c.Value
          End If
        End If
      Next c
      Cells(r, 9) = Join(.Keys, ", ")
    End If
    r = r + n - 1
    .RemoveAll
  Next r
End With
Columns(9).AutoFit
Application.ScreenUpdating = True
End Sub

My actual spread sheet has more columns so I had to modify the macro

Click to expand...

mikerickson said:

You could use this UDF, with a formula like
=IF(MATCH(A3, A:A, 0) = ROW(A3),ConcatIf(A:A, A3, C:C,", ",TRUE), "")

Code:

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
                    Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
                    
    Rem the first three argumens of ConcatIf mirror those of SUMIF
    Rem the Delimiter and NoDuplicates arguments are optional (default "" and False)
    Dim i As Long, j As Long
    
    With compareRange.Parent
        Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
    End With
    
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                            stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(Delimiter & ConcatIf & Delimiter, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function

Click to expand...