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

'присваиваем массиву диапазон ячеек с исходным списком элементов
  Стр = (Application.CountA(ActiveSheet.Columns(8)) + 1) - 1
  Cells(Стр, 9).Activate
  k = ActiveCell.Address

'присваиваем массиву диапазон ячеек с исходным списком элементов
    Arr = Range("$H$2:" + k)
'***заполняем 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
        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
'**********************************************************************************
lstKod.ColumnWidths = "0;150"

End Sub