Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
       UserForm1.Show
    
    'если у нас отсутствует значение в именованом диапазоне мы его добавим
       
    If IsEmpty(Target) Then Exit Sub   'если нажата клавиша эскейп то заканчиваем работу с выделеной ячейкой
       
    If WorksheetFunction.CountIf(Worksheets("dbTresh").Range("ФИО"), Target) = 0 Then   'выполняем поиск в диапазоне на наличие там имеющегося значения
          lReply = MsgBox("Добавить новое значение  " & _
                         Target & " в БД?", vbYesNo + vbQuestion)
          If lReply = vbYes Then
                   
          'вставляем в именованый диапазон новое значение
            
            sch = 4
            Do While Worksheets("dbTresh").Cells(sch, 1) <> "" 'Находим первую пустую строку в именованом диапазоне
                sch = sch + 1
            Loop
                      
            Worksheets("dbTresh").Cells(sch, 1) = Target  'присваиваем этой строке значение из комбобокс
            
            'создаем именованный диапазон для этого найдем его местоположение в БД
            Sheets("dbDiap").Select
            schI = 1
            Do While Worksheets("dbDiap").Cells(3, schI) <> "" 'Находим первый пустой столбец
                schI = schI + 2
            Loop
            
            'собственно как заставить создаваться Диапазон в зависимости от Толбца?
            Worksheets("dbDiap").Cells(3, schI) = Target.Value
            ActiveWorkbook.Worksheets("dbDiap").Names.Add Name:=Target.Value, _
                RefersTo:=Worksheets("dbDiap").Cells(3, schI).Resize(9)
            
            End If
        End If
    End If
End Sub

ActiveWorkbook.Names.Add Name:=Target.Value, RefersTo:=Worksheets("dbDiap").Cells(3, schI).Resize(9)