Перезапись данных и сохранение данных в выпадающем списке

Question

Я хотел бы знать, возможно ли перезаписать строки новыми данными, но при этом сохранить предыдущие данные в раскрывающемся списке? То, что я пытаюсь сделать, это перебрать список партнеров, и если условие истинно, добавить данные в новую строку, взять эти данные и создать раскрывающийся список, а затем перейти к следующему сотруднику. Код, который у меня есть, работает, но он добавляет к предыдущим данным и просто увеличивает выпадающий список. Я также пробовал clearContents в столбце (3) после завершения внутреннего цикла, но он очищает данные предыдущего выпадающего списка.

        For j = 2 To GetRowLength("HR")
            If shHR.Range("B" & j) = shIS.Range("F" & i) Then
                shHR.Range("C" & GetRowLength("HR", 3) + 1) = shHR.Range("A" & j)
            End If
        Next j

        With shIS.Range("O" & i).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=HR!$C:$C"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With

    Next i 


    For i = 2 To GetRowLength("Interview_Schedule")
        For j = 2 To GetRowLength("HR")
            If shHR.Range("B" & j) = shIS.Range("F" & i) Then
                shHR.Range("C" & GetRowLength("HR", 3) + 1) = shHR.Range("A" & j)
            End If
        Next j

        Dim arr()
        arr = Application.Transpose(shHR.Range("C:C").SpecialCells(xlCellTypeConstants).Value)
        With shIS.Range("O" & i).Validation
            .Delete
            ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
            arr(UBound(arr)) = shIS.Range("O" & i)
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Join(arr(), ",")
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With

    Next i

Answer 1

Вместо этого вы можете использовать динамический массив в определении Formula1. Посмотрите этот код, но я не уверен, что вы ищете это:

ПРИМЕЧАНИЕ. У этого решения есть предел -> LEN (Join (arr (), ",")) <=8190 </strong>

Dim bAddNewItem As Boolean
Dim arr()

' Fill out an array once somewhere at the beginning of the procedure
arr = Application.Transpose(Sheet("HR").Range("C:C").SpecialCells(xlCellTypeConstants).Value)

' If You want to add new item change to True
bAddNewItem = False

With Selection.Validation
    .Delete
    If bAddNewItem Then
        ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
        arr(UBound(arr)) = Selection.Value
    End If
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Join(arr(), ",")
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With

Если вы хотите работать с большими данными, необходимо использовать именованные диапазоны

    ' Add this line before updating Column C    
    ActiveWorkbook.Names.Add name:="myRng", RefersTo:="=" & Sheet("HR").Range("C:C").SpecialCells(xlCellTypeConstants).Address

    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=myRng"
        ' rest of code