Private Sub txtKod_Change()
    FillList txtKod.Text
End Sub

Private Sub UserForm_Activate()
    Call FillList
End Sub

Private Sub FillList(Optional txtfltr As String)
    dim lt As Integer
    lt = Len(txtfltr)
    lstKod.Clear
'***выбор листа*****************************************************************
    Sheets("База").Select
       Dim myRange As Range, myCell As Range, myCollection As New Collection, _
           myElement As Variant, i As Long

   'присваиваем переменной myRange диапазон ячеек с исходным списком элементов
     Set myRange = Range("A2:A5010")

'***заполняем ListBox уникальными элементами***********************************
    On Error Resume Next
    For Each myCell In myRange
        If Left(myCell, lt) = txtfltr Then myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
    Next myCell
    On Error GoTo 0

    For Each myElement In myCollection
        frmFind.lstKod.AddItem myElement
    Next myElement

'***сортировка ListBox**********************************************************
    With lstKod: iCountList = .ListCount - 1

        For iCount = iCountList To 1 Step -1
         For iCountTemp = iCountList To 1 Step -1
          If StrComp(.List(iCountTemp), .List(iCountTemp - 1), vbTextCompare) = -1 Then
             .AddItem .List(iCountTemp), iCountTemp - 1
             .RemoveItem iCountTemp + 1
          End If
         Next
        Next
    End With
'**********************************************************************************
End Sub

Private Sub txtKod_Change()
    FillList txtKod.Text
End Sub

Private Sub UserForm_Activate()
    Call FillList
End Sub

Private Sub FillList(Optional txtfltr As String)
    Dim lt As Integer, Arr
    lt = Len(txtfltr)
    lstKod.Clear
'***выбор листа*****************************************************************
    Sheets("База").Select
       Dim myRange As Range, myCell As Range, myCollection As New Collection, _
           myElement As Variant, i As Long

   'присваиваем массиву диапазон ячеек с исходным списком элементов
     Arr = Range("A2:A5010")

'***заполняем ListBox уникальными элементами***********************************
    On Error Resume Next
    For i = 1 To UBound(Arr, 1)
        If Left(Arr(i, 1), lt) = txtfltr Then myCollection.Add CStr(Arr(i, 1)), CStr(Arr(i, 1))
    Next
    On Error GoTo 0

    For Each myElement In myCollection
        frmFind.lstKod.AddItem myElement
    Next myElement

'***сортировка ListBox**********************************************************
    With lstKod: iCountList = .ListCount - 1
        For iCount = iCountList To 1 Step -1
         For iCountTemp = iCountList To 1 Step -1
          If StrComp(.List(iCountTemp), .List(iCountTemp - 1), vbTextCompare) = -1 Then
             .AddItem .List(iCountTemp), iCountTemp - 1
             .RemoveItem iCountTemp + 1
          End If
         Next
        Next
    End With
'**********************************************************************************
End Sub