Sub Выбор()
    Dim rng As Range, arr As Variant, arr1 As Variant, arr2 As Variant, n As Long
    Set sca = CreateObject("System.Collections.ArrayList")
    Set rng = Application.InputBox("Выделите диапазон в графике", "Данные", Type:=8)
    If rng Is Nothing Then MsgBox "Отмена выполнения", vbCritical, "Нет данных": Exit Sub
    arr = rng.Value
    Set rng = Application.InputBox("Выделите диапазон в базе", "Данные", Type:=8)
    If rng Is Nothing Then MsgBox "Отмена выполнения", vbCritical, "Нет данных": Exit Sub
    arr1 = rng.Value
    For Each i In arr
        If i <> "" Then If Not sca.contains(CStr(i)) Then sca.Add CStr(i)
    Next i
    sca.Sort
    ReDim arr2(1 To sca.Count, 1 To 1)
    For n = 1 To UBound(arr2)
        For m = 1 To UBound(arr1)
            If UCase(Replace(sca.Item(n - 1), " ", "") & "-") = UCase(Left(Replace(arr1(m, 1), " ", ""), Len(Replace(sca.Item(n - 1), " ", "")) + 1)) Then
                arr2(n, 1) = arr1(m, 1)
                Exit For
            Else
                arr2(n, 1) = sca.Item(n - 1)
            End If
        Next m
    Next n
    Set rng = Application.InputBox("Выделите ячейку для вставки результата", "Данные", Type:=8)
    If rng Is Nothing Then MsgBox "Отмена выполнения", vbCritical, "Нет данных": Exit Sub
    rng(1).Resize(UBound(arr2)) = arr2
End Sub