Зависимый раскрывающийся список в столбце

Question

Что мне нужно
Два столбца, один со раскрывающимся списком в каждой строке, где я могу выбрать код, другой со раскрывающимся списком в каждой строке, где будет отображаться субкод на основе в этом списке выбора.

Что у меня есть
Код, который заполняет весь столбец J кодом VBA:

Sub main()
Dim lCopyLastRow As Long
lCopyLastRow = Workbooks("Reports.xlsm").Worksheets("Data").Cells(Workbooks("Reports.xlsm").Worksheets("Data").Rows.Count, "AT").End(xlUp).Row

'replace "J2" with the cell you want to insert the drop down list
With Range("J2").Validation
    .Delete
    'replace "=A1:A6" with the range the data is in.
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
      Operator:=xlBetween, Formula1:="=Data!$AT$2:$AT$" & lCopyLastRow
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

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

Sub main2()
Dim lCopyLastRow As Long

'replace "J2" with the cell you want to insert the drop down list
With Range("K2").Validation
    .Delete
    'replace "=A1:A6" with the range the data is in.
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
      Operator:=xlBetween, Formula1:="=OFFSET(Data!$E$1,MATCH($J2,Data!$C$2:$C$6253,0),0,COUNTIF(Data!$C$2:$C$6253,$J2))"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

Я знаю, что проблема в формуле.

Файл Excel

Answer 1

Задача довольно проста, если ее правильно объяснить.

Вот концепция:
J-ячейка - это измененная ячейка в столбце "J", K-ячейка - это ячейка в столбце "K" в той же строке, что и J-ячейка.
1. Установите проверку данных для столбца "J" при открытии книги;
2. Поймайте каждое изменение любой из отдельных J-ячеек;
3. Создайте список проверки на основе значения J-ячейки;
4. Убедитесь, что такой список создан и имеет значения;
5. Установите проверку данных для K-ячейки.

Решение:
Обеспечить концепцию № 1 - создать обработчик для Workbook_Open события

Код для этого:

Private Sub Workbook_Open()

' Set data validation to column "J" (concept #1)
SetValidationToJ
End Sub

Создайте обработчик для события Worksheet_Change, убедитесь, что выбрали правильный лист и событие.

Код для этого обработчика события (см. комментарии):

Private Sub Worksheet_Change(ByVal Target As Range)
' Target - is the changed cell or range of cells
Dim dataArray()

With Target.Parent
    ' the check to catch a change of single cell only
    If Not Target.Rows.Count > 1 And Target.Columns.Count > 1 Then
        ' check that this cell in column "J" (concept #2)
        If Not Intersect(Target, .Columns(10)) Is Nothing Then
            ' if cell was just cleared
            If Target.Value = "" Then
                ' then remove validation from appropriate cell in column "K"
                .Cells(Target.Row, 11).Validation.Delete
            Else
                ' otherwise try to generate validation list (concept #3)
                dataArray = GetValuesForKValidation(Target)

                ' if validation list has some values (concept #4)
                If Not Not dataArray Then
                    ' set validation to appropriate cell in column "K" (concept #5)
                    SetValidationToK dataArray, Target.Row
                Else
                    'if no values - remove old validation as inappropriate
                    .Cells(Target.Row, 11).Validation.Delete
                    '[... your handler for other stuff...]
                End If
            End If
        End If
    End If
End With

End Sub

А оставшаяся часть кода (2 подпрограммы и 1 функция) должна быть размещена в обычном модуле:

Option Explicit
Dim dataSht As Worksheet

Sub SetValidationToJ()
Dim lastRow As Long
Dim sourceRngJ As Range

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    Set sourceRngJ = Range(.Cells(2, 46), .Cells(Rows.Count, 46).End(xlUp))
    lastRow = .Cells(Rows.Count, 46).End(xlUp).Row

    With Range(.Cells(2, 10), .Cells(lastRow, 10)).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=" & sourceRngJ.Address
        .IgnoreBlank = True
        .InCellDropdown = True
        .ErrorTitle = "Error!"
        .ErrorMessage = "You must select from provided list!"
        .ShowError = True
    End With
End With

End Sub

Sub SetValidationToK(Values() As Variant, RowNum As Long)

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    With .Cells(RowNum, 11).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:=Join(Values, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ErrorTitle = "Error!"
        .ErrorMessage = "You must select from provided list!"
        .ShowError = True
    End With
End With

End Sub

Function GetValuesForKValidation(SrcRange As Range) As Variant
Dim r As Range, searchRange As Range
Dim output() As Variant
Dim i As Integer

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    Set searchRange = Range(.Cells(2, 3), .Cells(Rows.Count, 3).End(xlUp))
End With

For Each r In searchRange
    If r.Value = SrcRange.Value Then
        ReDim Preserve output(i)
            output(i) = r.Offset(0, 2).Value
            i = i + 1
    End If
Next

GetValuesForKValidation = output

End Function

Комментарии приветствуются.