Фильтр макроса для подсчета Отличное уникальное значение

Question

У меня есть такая таблица, где я должен использовать макрос, потому что моя таблица всегда меняется каждый день (SSAS), поэтому я использую макрос для автоматической фильтрации,

Я могу суммировать сумму на основе того же Vendorname, PONuber и Date в столбце E (промежуточный итог).

и затем фильтровать показать итоговую сумму> 500

Я хочу показать только строку> 500 (столбец E) и всплывающее сообщение, чтобы подсчитать PONumber (столбец B), сколько уникальных номеров PO (только видимая строка для подсчета)

я застрял, как считать только видимый уникальный номер 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

и это формула для подсчета

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

Answer 1

Если вы извлекаете данные из базы данных через SSAS, вы можете использовать Power Query для связи с вашей SSAS DataModel в Excel, и вы можете вставить вычисленную меру в Dax оттуда с помощью DistinctCount.

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

В качестве альтернативы, если вам нужна полная информация по указанной проблеме, вы можете добавить измеренный столбец, а затем использовать Power Pivot для фильтрации ваших критериев в реальном времени по refre sh к модели данных, полностью исключая необходимость в VBA.

Между прочим, уместно помнить, что VBA - кувалда для решений. Пожалуйста, используйте инструменты DataModel, прежде чем вы когда-либо задумываетесь о макро-решении. Помните, VBA - это язык прикладного программирования, и многие системы безопасности ИТ отключат его, потому что он открывает Система на вредоносное ПО, вы можете буквально изменить любой файл или программу в VBA, в том числе вызывая удаление системных файлов

Между тем, установка DataModel в заблокированном файле, который требует доступа пользователя за безопасность локальной сети, легко более безопасный, чем n позволяя вашему компьютеру иметь открытый доступ к программам c.

Answer 2

Во-первых, чтобы ваш счетчик кода работал, давайте изменим все с "" на "" ""

Во-вторых, чтобы иметь возможность уведомить уникальный номер PO и показать его в всплывающем сообщении, Вы должны вызвать значение, полученное из ячейки G1, или, безопаснее, использовать метод оценки, чтобы получить результат этого выражения. Ваш код, вероятно, теперь будет работать

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

, однако ваша формула учитывает только все уникальные значения, включая менее 500, и, кроме того, она довольно длинная. Вы можете заменить его, используя более короткую формулу, например, следующий код:

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"

Надеюсь, это поможет!

Answer 3

Используйте 2 Словарь объектов , один для итогов и один для уникальных PO

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

Answer 4

Шаг 1. Отправьте мой код в новый модуль.

Шаг 2. Привязайте кнопку к макросу с именем «filterAndCount»

Шаг 3. Нажмите на кнопку и радуйтесь :-)

Описание кода:

1) Код зацикливает все строки в таблице.

2) Сначала проверяется, превышает ли промежуточный итог предел (500).

3) Если оно равно или меньше, оно скрывает строку и переходит к следующей строке.

4) Если оно выше, оно проверяет, существует ли уже значение в значениях массива выше.

5) Если он не существует, то значение добавляется в массив.

6) Когда все строки зациклены, отображаются только строки с общей суммой, превышающей ограничение.

7) В массив добавлены только уникальные и видимые номера PO.

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

Answer 5

Вы можете использовать следующий код. Я реализовал Collection, чтобы получить уникальный счет.

Это будет считать уникальные строки в B column, где 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

Answer 6

Формула для вашей ячейки E2, которая не является формулой массива, имеет вид

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

Скопируйте ее, как обычно. См. здесь , почему бы не использовать формулу массива (если у вас есть альтернатива).

Я не уверен, что это решит ваш вопрос, поскольку я не полностью понял его.

Answer 7

Это альтернативная формула (не требующая фильтрации)

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

Это формула массива, поэтому с использованием VBA

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