Sub Список(Optional Target As Range)
'добавляет в ячейку список проверки/выбора
Dim InVal() As Variant
Dim OutVal() As Variant
Dim OutVal2 As String
If TypeName(Target) <> "Range" Then Set Target = ThisWorkbook.Worksheets("Печатная форма").Range("D1")
InVal = ThisWorkbook.Worksheets("Исходные данные 2").Range("E1:E100").Value
Set dicRow = CreateObject("scripting.dictionary")
    With dicRow
        .comparemode = 1
        .Add InVal(1, 1), 1
        For i = 1 To UBound(InVal, 1)
            If Not .Exists(InVal(i, 1)) Then .Add InVal(i, 1), InVal(i, 1)
        Next i
        .Remove (InVal(1, 1))
        OutVal = .keys
    End With
    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=Join(OutVal, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
Range("D1").Select
End Sub