Поле со списком, где доступные варианты являются уникальными и зависит от выбора в предыдущем поле со списком

Question

У меня есть набор данных в другом файле, который имеет 3 столбца с тысячами строк.Все 3 столбца имеют значения, которые не являются уникальными.

Мне нужно 3 поля со списком.

Первое поле со списком предназначено для выбора из столбца «А» (возвращая уникальные значения) для различных типов.бизнес-единиц.

Далее, в зависимости от бизнес-единицы, поле со списком 2 предназначено для выбора конкретного клиента (в зависимости от выбранной бизнес-единицы).

Наконец, поле со списком 3 предназначено для выбораиз разных МВЗ, существующих для данного клиента.

Мне нужны уникальные значения для всех 3 столбцов.

Мне кажется, у меня есть поле со списком 1 со следующим кодом:

Option Explicit

Private Sub UserForm_Initialize()

Dim wbExternal As Workbook   '<-- the other workbook with the data
Dim wsExternal As Worksheet  '<-- the worksheet in the other workbook
Dim lngLastRow As Long       '<-- the last row on the worksheet
Dim rngExternal As Range     '<-- range of data for the RowSource
Dim myCollection As collection, cell As Range
On Error Resume Next

Application.ScreenUpdating = False

Set wbExternal = Application.Workbooks.Open("C:\Users\sarabiam\desktop\OneFinance_Forecast_Model\FY19_New_Forecast_Model_Data_Tables.xlsm", True, True)
Set wsExternal = wbExternal.Worksheets("#2Table_Revenue") '<-- identifies worksheet
Set rngExternal = wsExternal.Range("A8:A" & CStr(lngLastRow))
Set myCollection = New collection

With ComboBox1
    .Clear

    For Each cell In Range("A8:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Len(cell) <> 0 Then
            Err.Clear
            myCollection.Add cell.Value, cell.Value
            If Err.Number = 0 Then .AddItem cell.Value
        End If
    Next cell

End With
ComboBox1.ListIndex = 0

wbExternal.Close

Application.ScreenUpdating = True  '<-- updates the worksheet on your screen 
any time there is a change within the worksheet

End Sub

Answer 1

Вот довольно общий подход - он загружает данные только один раз в массив, а затем использует его для сброса содержимого списка при выборе «предыдущего» списка.

Option Explicit

Const dataPath As String = "C:\Users\usernameHere\Desktop\tmp.xlsx"
Dim theData 'source data

Private Sub UserForm_Activate()
    LoadData
    Me.cboList1.List = GetList(1, "")
End Sub

Private Sub cboList1_Change()
    Me.cboList2.Clear
    Me.cboList2.List = GetList(2, Me.cboList1.Value)
    Me.cboList3.Clear
End Sub

Private Sub cboList2_Change()
    Me.cboList3.Clear
    Me.cboList3.List = GetList(3, Me.cboList2.Value)
End Sub

'Return unique values from source data, given a specific column
'  If given a value for "restrictTo", filter on match in column to "left"
'  of the requested value column
Function GetList(colNum As Long, restrictTo)
    Dim i As Long, n As Long, rv()
    Dim dict As Object, v, ub As Long, inc As Boolean

    Set dict = CreateObject("scripting.dictionary")
    ub = UBound(theData, 1)
    ReDim rv(1 To ub) 'will set final size after filling...
    n = 0

    For i = 1 To ub

        v = theData(i, colNum)
        'are we restricting the values we collect based on a different list?
        If colNum > 1 And Len(restrictTo) > 0 Then
            'is this value valid?
            inc = (theData(i, colNum - 1) = restrictTo)
        Else
            inc = True 'collect all values
        End If

        If inc And Not dict.exists(v) Then
            'don't already have this value - add to array and dict
            n = n + 1
            dict.Add v, True
            rv(n) = v
        End If

    Next i
    ReDim Preserve rv(1 To n) 'resize array to size of content
    GetList = rv
End Function

'load data from external file
Private Sub LoadData()
    With Workbooks.Open(dataPath).Worksheets("#2Table_Revenue")
        theData = .Range(.Range("A8"), _
                         .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2)).Value
        .Parent.Close False
    End With
End Sub