Counting Unique Value Pairs in 2 Columns

[mykal66]

Hi everyone

I have a spreadsheet with several columns one of which is staff member which is in column C. Column B then has a range of values associated with the staff member in column C. I need to be able to count unique values in column B associated with the staff member in Columns C. I have a formula that works manually when i fleeter the staff member in column C.

{=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B3,ROW(B3:B5000)-ROW(B3),,1)),
IF(B3:B5000<>"",MATCH("~"&B3:B5000,B3:B5000&"",0))),ROW(B3:B5000)-ROW(B3)+1),1))}

Does anyone know if i can automate the count on a separate sheet rather than a manual process please?

I've attached an example of what i need, the main data would be on sheet 1 with results on sheet 2. In the example workbook I've manually entered the values i would expect to see (which the formula above does return with the manual process)

Thanks as always in advance

Mykal

14447

[Trebor76]

Does anyone know if i can automate the count on a separate sheet rather than a manual process please?

Maybe not the most efficient way - but this will do the job:


Option Explicit

Sub Macro1()

Dim rngMyCell As Range
Dim clnMyUniqueNames As New Collection
Dim clnMyUniqueItems As New Collection
Dim varMyUniqueName As Variant
Dim lngMyCount As Long

Application.ScreenUpdating = False

'First get an unique list of names from Col. B in 'Sheet1'
For Each rngMyCell In Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row)
If Len(rngMyCell) > 0 Then
On Error Resume Next 'OK to ignore Run-time error '457' This key is already associated with an element of this collection' error message as we're only interested in unique items anyway
clnMyUniqueNames.Add Item:=rngMyCell.Value, Key:=CStr(rngMyCell.Value)
On Error GoTo 0 'Nullify error handler
End If
Next rngMyCell

'Now produce an unique count for all the items for each unique name
For Each varMyUniqueName In clnMyUniqueNames
For Each rngMyCell In Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row)
If CStr(varMyUniqueName) = CStr(rngMyCell) Then
On Error Resume Next 'OK to ignore Run-time error '457' This key is already associated with an element of this collection' error message as we're only interested in unique items anyway
clnMyUniqueItems.Add Item:=rngMyCell.Offset(0, -1).Value, Key:=CStr(rngMyCell.Offset(0, -1).Value)
If Err.Number = 0 Then
lngMyCount = lngMyCount + 1
End If
Err.Clear
On Error GoTo 0 'Nullify error handler
End If
Next rngMyCell
'Output results to 'Sheet2'
With Sheets("Sheet2")
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = CStr(varMyUniqueName)
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = lngMyCount
End With
'Initialise variables for next 'varMyUniqueName'
lngMyCount = 0
Set clnMyUniqueItems = Nothing
Next varMyUniqueName

Application.ScreenUpdating = True

MsgBox "Done."
End Sub

Regards,

Robert

[snb]

a pivottable: