VBA: установите массив, равный критериям фильтра

Question

В настоящее время у меня есть данные, которые уже отфильтрованы по типу бизнеса. Я хочу заполнить массив значениями из другого столбца без повторов. Другими словами, я хочу заполнить массив критериями фильтрации из другого столбца.

Критерии фильтрации в другом столбце будут меняться в зависимости от того, какой бизнес-тип выбран, поэтому заполнение массива должно быть динамическим c .

Я исследовал это в Интернете и пока нашел только то, что не работает:

Dim tempArr As Variant

tempArr = Sheets("Sheet1").Filters.Criteria1

Пример данных

buisUnit   ProfCenter
SHS        1
SHS        1
SHS        2
SHS        3
SHS        4
ALT        5
ALT        6
ALT        6
ALT        7

Итак, если мои данные фильтруется по buis unit = SHS. Я бы хотел tempArray = (1,2,3,4), если бы фильтровал по ALT, я бы хотел (5,6,7)

Заранее спасибо.

Answer 1

Воспользуйтесь следующей функцией, пожалуйста. Требуется ссылка на «Microsoft Scripting Runtime». Если вы не можете добавить его (даже если это очень просто), просто закомментируйте первую строку объявления и не комментируйте вторую:

Function FilterArray(arr As Variant, strSearch As String) As Variant
    Dim dict As New Scripting.Dictionary
    'Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, strKey As String
    For i = 1 To UBound(arr)
      If arr(i, 1) = strSearch Then
        strKey = arr(i, 1) & "|" & arr(i, 2)
        If Not dict.Exists(strKey) Then
           dict.Add strKey, arr(i, 2)
        End If
      End If
  Next i
   If dict.Count = 0 Then FilterArray = "": Exit Function
   FilterArray = dict.Items
End Function

Он будет вызываться следующим образом:

Sub testFilterArr()
  Dim sh As Worksheet, arr As Variant, strSearch As String, lastRow As Long
  
   Set sh = ActiveSheet 'use here the necessary sheet
   lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
   arr = sh.Range("A2:B" & lastRow).Value
   strSearch = "SHS"
   arr = FilterArray(arr, strSearch)
   If IsArray(arr) Then
       Debug.Print Join(arr, ",")
   Else
       MsgBox "No any result for """ & strSearch & """..."
   End If
End Sub