The Worldâ€™s Largest Online Community for Developers

';
excel - Macro to Count Filter Distinct unique Value - LavOzs.Com
excel vba

I Have Table like this, where i have to use macro because my table always change Every day (SSAS) so i have use macro to filter automatically,

I am able to sum Amount based on same Vendorname, PONuber and Date on Column E (Subtotal).

and then filter to show Subtotal AMount >500

I want to show only row >500 (Column E), and pop up message to count PONumber (Column B) how many Unique PO Number (Only Visible Row to count)

i've been stuck how to count only Visible Unique PO Number and show it on Pop Up message

this is my Macro

```
Sub FilterCOunt_Click()
Dim Condition As Variant
Dim AVal As Variant
Dim LastRow As Long
Dim Hide, popup As Long
Dim message As String
Dim sht As Worksheet
'----------------------------
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
'---------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.StatusBar = False
'------------------
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("E:Z").EntireColumn.Delete
Range("E:Z").EntireColumn.Insert
Range("E1").Value = "Sub Total >500 "
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
'-------------------
For i = 2 To LastRow ' with last row count =SUMIFS(I:I,A:A,A8,B:B,B8,C:C,C8)
AVal = "A" & i
BVal = "B" & i
CVal = "C" & i
Worksheets("Sheet3").Range("E" & i).Formula = "=SUMIFS(D:D,A:A," & AVal & ",B:B," & BVal & ",C:C," & CVal & ")"
Next i
With sht.Range("E1:E" & LastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=500"
End With
'----------Count Pop UP
Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH(""&B2:B22,B2:B22&"",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & CountPO & " PO Open(s)", _
vbInformation, "PO Found"
End Sub
```

and this is the formula to count it

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

If you are pulling from a Database via SSAS you can use Power Query to link to your SSAS DataModel to Excel and you can insert a Calculated Measure in Dax from there with DistinctCount.

```
Count:=Calculate(DistinctCount(TableName[PONumber]),TableName[Amount]>500)
```

Alternatively if you want total insights on your specified issue you can add a measured column and then you can use Power Pivot to filter for your criteria live on refresh to the data model, completely negating the need for VBA entirely.

*Incidentally it is pertinent to remember VBA is the sledge hammer of solutions please use the DataModel Tools before you ever think of a macro solution remember, VBA is an Application Programming Language and many IT Security Systems will disable it because it opens the system up for malware, you can literally change any file or program in VBA including calling delete system files*

*Meanwhile having a set DataModel in a locked file that requires user access behind LAN security is easily more secure than allowing your computer to have open programatic access.*

This is an alternative formula (which doesn't require any filtering)

```
=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))
```

It's an array formula so using VBA

```
Range("E1").FormulaArray = "=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))"
```

A formula for your cell E2, which is not an array formula, is

```
=SUMPRODUCT((B2=B$2:B$23)*(A2=A$2:A$23)*(D$2:D$23))
```

Copy it down, as usual. See here for why not using an array formula (if you have an alternative).

I am not certain this solves your question, as I did not fully understand it.

You can use the following code. I have implemented `Collection`

to get the unique count.

This will count the unique rows in `B column`

where `value in E column > 500`

.

```
Private Sub GetUniqueCount() AS Variant
Dim Test As New Collection
Dim rng As Range
For i = 2 To 6 'Replace 6 with last row(without filtration)
Value = Cells(i, "B").Value
check = Contains(Test, Value)
If Cells(i, "E").Value > 500 And Not check And Len(Value) > 0 Then
Test.Add Value, CStr(Value)
End If
Next i
GetUniqueCount = Test.count
End Sub
'Function to check if the value exists in Collection or not
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
```

Step 1: Post my code to a new module.

Step 2: Bind you button to the macro named "filterAndCount"

Step 3: Click the buton and rejoice :-)

Code description:

1) The code loops all the rows in the table.

2) First it checks if the Sub Total is above the limit (500).

3) If equal or below it hides the row and moves on to the next row.

4) If above it checks if the value already exists in the array values above.

5) If it does not exists then the value is added to the array.

6) When all rows have been looped only rows with a Sub Total above the limit is visible.

7) Only the unique and visible PO Numbers have been added to the array.

8) The number of values in the array is dispayed in a message box.

```
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Double
Dim n As Double
Dim subTotalLimit As Double
Dim arr() As String
Sub filterAndCount()
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
i = 2
subTotalLimit = 500
n = 0
ReDim arr(0 To 0) As String
arr(0) = 0
ws.Columns("E:Z").EntireColumn.Delete
ws.Range("E:Z").EntireColumn.Insert
ws.Range("E1").Value = "Sub Total >500 "
Do While ws.Range("B" & i) <> ""
ws.Range("E" & i).Formula = "=SUMIFS(D:D,A:A,A" & i & ",B:B,B" & i & ",C:C,C" & i & ")"
If ws.Range("E" & i) < subTotalLimit Then
ws.Range("B" & i).EntireRow.Hidden = True
Else
If Not IsNumeric(Application.Match(Range("B" & i).Text, arr(), 0)) Then
arr(n) = Range("B" & i).Value
n = UBound(arr) + 1
ReDim Preserve arr(0 To n) As String
arr(n) = 0
End If
End If
i = i + 1
Loop
MsgBox UBound(arr)
End Sub
```

Use 2 Dictionary Objects, one for totals and one for unique PO's

```
Sub filterCOunt()
Const LIMIT = 500
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, amount As Single
Dim sVendor As String, sPO As String, msg As String, sKey As String
Dim dictPO As Object, dictTotal As Object
Set dictPO = CreateObject("Scripting.Dictionary")
Set dictTotal = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = ActiveSheet
iLastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
' first pass to total by po and vendor
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
amount = CSng(ws.Cells(iRow, 4))
sKey = sVendor & "_" & sPO
' sub total
If dictTotal.exists(sKey) Then
dictTotal(sKey) = dictTotal(sKey) + amount
Else
dictTotal.Add sKey, amount
End If
Next
' second pass for PO numbers
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
sKey = sVendor & "_" & sPO
' sub total
ws.Cells(iRow, 5) = dictTotal(sKey)
If dictTotal(sKey) > LIMIT Then
If Not dictPO.exists(sPO) Then
dictPO.Add sPO, iRow
End If
End If
Next
' filter
With ws.Range("E1:E" & iLastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=" & LIMIT
End With
msg = "No of open PO's = " & dictPO.Count
MsgBox msg, vbInformation
End Sub
```

First, for your code Count Pop UP to work, let's change all from "" to """"

Second, to be able to notify a Unique PO Number and show it on Pop Up message, you must call the value received from cell G1, or, safer, use evaluate to get the result of this expression. Your code will probably work now

```
'Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"""",MATCH(""""&B2:B22,B2:B22&"""",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & [g1].Value2 & " PO Open(s)", vbInformation, "PO Found"
```

however, your formula only counts all unique values including less than 500, in addition it is quite long. You can replace it using the shorter formula like the following code:

```
Dim formula_string As String
formula_string = "=SUMPRODUCT((B2:B22>3)*(C2:C22<>"""")/COUNTIF(B2:B22,B2:B22&""""))"
MsgBox "We Found " & Application.Evaluate(formula_string) & " PO Open(s)", vbInformation, "PO Found"
```

Hope it helps!

Related

Comparing the cell values and printing the count in Excel using a formula or function?

Getting Error messages on ranges

Copy certain excel columns based on ones criteria

VB macro to merge to data set based on several conditions via an array

Excel VBA to SUMIF Range only if Range is not completely Blank

Excel VBA macro to send emails to unique users in range

Need to Copy Data only if Header is “Name”

Comparing the cell values and printing the count in Excel using a formula or function?

Getting Error messages on ranges

Copy certain excel columns based on ones criteria

VB macro to merge to data set based on several conditions via an array

Excel VBA to SUMIF Range only if Range is not completely Blank

Excel VBA macro to send emails to unique users in range

Need to Copy Data only if Header is “Name”