Find et navn

Option Explicit
Dim Ark As Worksheet
Dim oleobj As OLEObject
Const sArk As String = "Ark2" ' Arket med navnene
Const sNavn As String = "$A$2" ' Adressen til cellen du skriver navn i


Private Sub NavnCombo_Change()
    Application.ScreenUpdating = False
    Set Ark = Sheets(sArk)
    With NavnCombo
        Dim Arr() As Variant, D1 As Object, cl, c
        Arr = Ark.Range("B2:B" & Ark.[B65000].End(xlUp).Row) 'Kolonne med navne, her B
        If NavnCombo <> "" And IsError(Application.Match(NavnCombo, Arr, 0)) Then
            Set D1 = CreateObject("Scripting.Dictionary")
            cl = UCase("*" & Replace(NavnCombo, " ", "*") & "*")
            For Each c In Arr
                If UCase(c) Like cl Then D1(c) = ""
            Next c
            .List = D1.keys
            .DropDown
        End If
        Range("A2").Value = .Value
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim Arr() As Variant
    Dim Column As Range
    Set Ark = Sheets(sArk)
    If Target.Address = sNavn Then
        Set oleobj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1")
        With oleobj
            .Name = "NavnCombo"
            .Height = Target.Height
            .Width = Target.Width
            .Left = Target.Left
            .Top = Target.Top
            .Activate
        End With
    Else
        ActiveSheet.OLEObjects.Delete
    End If
    Application.ScreenUpdating = True
End Sub