Всем Огромнейшее спасибо.
Все работает.

С.М. я премного вам благодарен, спасибо что потратили время на меня. Еще раз спасибо большое.
А все таки возможно, тоже самое реализовать путем диапазонов к примеру B3:B4000, C3:C4000 H3:H4000, и что бы не было синей обводки и выделения автофильтра???

))) не могу вам ответить грамотно, не компетентен в этом вопросе, я пытаюсь, как из пластилина, оторвать кусочек из чужих примеров и наработок, и прилепить к своему вопросу.
Может быть новый, более уточненный пример поможет вам меня понять.

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

скопировав ваш макрос, у меня сразу вылетает ошибка
на этой строке
Set Rng = Me.ListObjects(1).DataBodyRange.Columns(1).Resize(, 2)
причем без разницы просто выбрав значение из списка или добавить нового.

в предыдущем коде появляется ошибка в строке:
Set Rng = Me.ListObjects(1).DataBodyRange.Columns(1).Resize(, 2)
и объясните пожалуйста, правильно ли я понимаю что при таком методе, столбцы будут друг за другом или же можно, что бы они были через какое то количество столбцов?

 If Target.Count > 1 Then Exit Sub
   Set Rng = Me.ListObjects(1).DataBodyRange.Columns(1).Resize(, 2)
   Rem Me.ListObjects(1).DataBodyRange - диапазон "УмногоСписка" (без шапки).
   Rem замените 2 в .Resize(, 2) на необходимое число столбцов
   Select Case False
   Case Intersect(Target, Rng.Columns(1)) Is Nothing
       If Target <> "..Добавить нового.." Then Exit Sub
       sNewVal = InputBox("Введите наименование нового КонтрАгента, которое следует добавить", "Ввод нового КонтрАгента")
       If sNewVal = "" Then Target = sNewVal: Exit Sub
       Set Rng = Sheets("КонтрАгенты").Range("СписокКонтрАгенты")
   Case Intersect(Target, Rng.Columns(2)) Is Nothing
       If Target <> "..Добавить нового.." Then Exit Sub
       sNewVal = InputBox("Введите наименование нового КонтрАгента, которое следует добавить", "Ввод нового КонтрАгента")
       If sNewVal = "" Then Target = sNewVal: Exit Sub
       Set Rng = Sheets("ФИОКонтрАгенты").Range("СписокФИОКонтрАгенты")
'    Case Intersect(Target, Rng.Columns(3)) Is Nothing
'        .......
'    Case Intersect(Target, Rng.Columns(4)) Is Nothing
'        .......
'    ..............
   Case Else
       Exit Sub
   End Select
   With Rng
       If .Find(sNewVal, , xlValues, xlWhole) Is Nothing Then
           .Cells(2).Insert: .Cells(2, 1) = sNewVal: .Resize(.Rows.Count - 1).Sort .Cells(1, 1)
       Else
           MsgBox "Это уже присутствует в списке!", vbInformation, "Дубликат"
       End If
   End With
   Target = sNewVal
End Sub

)))) Сломал я, по всей видимости совсем.

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

C.M. премного благодарен, а также всем участникам огромное спасибо.
правильно я понимаю, что для оставшихся 5-ти столбцов, надо размножить:
Case Intersect(Target, Rng.Columns(1)) Is Nothing
       If Target <> "..Добавить нового.." Then Exit Sub
       sNewVal = InputBox("Введите наименование нового КонтрАгента, которое следует добавить", "Ввод нового КонтрАгента")
       If sNewVal = "" Then Target = sNewVal: Exit Sub
       With Sheets("КонтрАгенты").Range("СписокКонтрАгенты")
           If .Find(sNewVal, , xlValues, xlWhole) Is Nothing Then
               .Cells(.Rows.Count) = sNewVal
               .Sort .Cells(1)
           Else
               MsgBox "Данный КонтрАгент уже присутствует в списке!", vbInformation, "Дубликат"
           End If
       End With
       Target = sNewVal
Соответственно поменяв номера столбцов и указания наименований листов и списков.
На счет формулы =СМЕЩ(КонтрАгенты!$A$1:$A$1000;;;СЧЁТЗ(КонтрАгенты!$A$1:$A$1000))
понял, у меня запас 4000.

Юрий, спасибо, еще раз уточню, от программирования я далек. Как можно расширить диапазон, путем копирования блоков у меня не получилось, буду признателен если поправите макрос под мою задачу.
Как предлагает Кузьмич, так же признателен за ответ, макрос работает не корректно, при запуске во втором столбце (ФИО) добавление и сам список работает, а в первом (КонтрАгент) работает только список без добавления.
На самом деле, таких диапазонов списков предполагается 7 штук, если можно, поясните какие блоки в макросе необходимо размножить.

Добрый, вечер.
Начну с того что я не программист совсем, форум читал, много полезного из примеров взял.
в том числе и выпадающий список с добавлением.
Требуется на "Основном" листе разместить два диапазона выпадающих списков с добавлением.
Один берет данные с листа КонтрАгенты, другой с листа ФИОКонтрАгенты. Пожалуйста, прошу помочь исправить макрос.