Excel 宏来计算筛选器的不同唯一值

我有这样的表，我必须使用宏，因为我的表每天都在变化（SSAS） 所以我用宏自动过滤

我能够根据E列（小计）中相同的供应商名称、PONuber和日期对金额进行合计

然后过滤以显示小计金额>500

我只想显示行>500（列E），并弹出消息来计算PONumber（列B）有多少唯一的PO编号（只显示要计算的行）

我一直被困在如何只计算可见的唯一订单号，并显示在弹出消息

这是我的宏

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

子过滤器计数\u单击（）
变暗条件
Dim AVal作为变体
最后一排一样长
暗显隐藏，按长弹出
将消息设置为字符串
将sht变暗为工作表
'----------------------------
作为对象的Dim字典
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.entireclumn.Hidden=False
Rows.EntireRow.Hidden=False
列（“E:Z”）。entireclumn.Delete
范围（“E:Z”）。全部插入
范围（“E1”）.Value=“小计>500”
设置sht=ActiveSheet
LastRow=sht.Range（“B”和Rows.Count）.End（xlUp）.Row
'-------------------
对于i=2到最后一行，最后一行计数为SUMIFS（i:i，A:A，A8，B:B，B8，C:C，C8）
AVal=“A”&i
BVal=“B”&i
CVal=“C”和i
工作表（“表3”）.范围（“E”和i）.公式=“=SUMIFS（D:D，A:A，“&AVal&”，B:B，&BVal&”，C:C，&CVal&”）
接下来我
具有短范围（“E1:E”和最后一行）
.自动过滤器
.自动筛选字段：=1，标准1:=“>=500”
以
“-------计数弹出窗口
暗淡如长
范围（“G1”）.FormulaArray=“=总和（如果（频率）（如果（小计）（3，偏移量（B2，行（B2:B22）-行（B2），1）），如果（B2:B22）”，匹配（“&B2:B22，B2:B22&”，0）），行（B2:B22）-行（B2）+1））”
MsgBox“我们找到了”&CountPO和“PO未结”_
VBA信息，“找到PO”
端接头

这是计算它的公式

{=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))}

{=SUM（IF（频率）（IF（小计（3，偏移量（B2，行（B2:B22）-行（B2），1）），IF（B2:B22“”，匹配（“~”&B2:B22，B2:B22&“”，0））），行（B2:B22）-行（B2）+1）））

这是一个替代公式（不需要任何过滤）

这是一个数组公式，所以使用VBA

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

---

单元格E2的公式（不是数组公式）为

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

照常把它抄下来。 有关为什么不使用数组公式的信息，请参见（如果您有其他选择）

---

我不确定这是否解决了您的问题，因为我没有完全理解它。

您可以使用以下代码。我已经实现了

收集

以获取唯一计数

这将统计

B列

中的唯一行，其中

值在E列>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

---

如果您是通过SSAS从数据库中提取数据，则可以使用Power Query将SSAS数据模型链接到Excel，并使用DistinctCount在Dax中插入计算出的度量值

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

或者，如果您希望对指定问题有全面的了解，您可以添加一个测量列，然后使用Power Pivot对数据模型中的实时刷新条件进行筛选，完全不需要VBA

顺便提一句，记住VBA是解决方案的重锤请在想到宏解决方案之前使用数据模型工具记住，VBA是一种应用程序编程语言，许多it安全系统会禁用它，因为它会打开系统以防恶意软件，您可以在VBA中更改任何文件或程序，包括调用“删除系统文件”

---

同时，在一个锁定的文件中设置一个需要用户访问局域网安全的数据模型，比允许您的计算机具有开放式编程访问更安全。

步骤1：将我的代码发布到新模块

步骤2：将按钮绑定到名为“filterAndCount”的宏

第三步：点击布顿并欢呼：-）

代码说明：

1） 代码循环表中的所有行

2） 首先，它检查小计是否超过限制（500）

3） 如果等于或低于该值，则隐藏该行并移动到下一行

4） 如果在上面，则检查该值是否已存在于上面的数组值中

5） 如果该值不存在，则将该值添加到数组中

6） 当所有行都已循环时，只有小计超过限制的行才可见

7） 只有唯一可见的采购订单编号已添加到阵列中

8） 数组中的值数显示在消息框中

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

Dim wb As工作簿
将ws设置为工作表
我是双人的
双倍
Dim Subtallimit为双精度
Dim arr（）作为字符串
子筛选器帐户（）
设置wb=ThisWorkbook
设置ws=wb.ActiveSheet
i=2
小计极限=500
n=0
重拨arr（0到0）作为字符串
arr（0）=0
ws.Columns（“E:Z”）.entireclumn.Delete
ws.Range（“E:Z”）.entireclumn.Insert
ws.Range（“E1”）.Value=“小计>500”
在ws.Range（“B”和“i”）时执行
ws.Range（“E”&i）.Formula=“=SUMIFS（D:D，A:A，A”&i&“，B:B，B”&i&“，C:C，C”&i&“）
如果ws.Range（“E”&i）

使用2，一个用于总计，一个用于唯一采购订单

子过滤器计数（）
常数极限=500
将wb设置为工作簿，ws设置为工作表
暗淡的iRow为长，iLastRow为长，数量为单
Dim sVendor作为字符串，sPO作为字符串，msg作为字符串，sKey作为字符串
Dim dictPO作为对象，dictTotal作为对象
设置
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

'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"

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"