Список (ListBox) - Изменение порядка (сортировка) элементов списка

Private Sub ListResort(ctlList As Control, iDirection%)
'es - 17.01.2020
'Изменение порядка (сортировка) элементов в ListBox c фиксированным набором значений
'----------------------------------------------------------------
'Пример применения:
'    ListResort Me!lstTestList, -1 'Вверх
'    ListResort Me!lstTestList, 1  'Вниз
'----------------------------------------------------------------
Dim ArrList() As String
Dim sStartName As String, sEndName As String
Dim iPosStart As Integer, iPosEnd As Integer
Dim intRow%, sVal$, iListCount%, iColumnCount%, iColumn%

On Error GoTo ListResort_Err
   
'Проверочки:
    iListCount = ctlList.ListCount
    If ctlList.ListIndex = -1 Then Exit Sub
    If iDirection = -1 Then 'Вверх
        If ctlList.ListIndex = 0 Then Exit Sub 'начало списка
    Else 'Вниз
        If ctlList.ListIndex = ctlList.ListCount - 1 Then Exit Sub
    End If
    
'----------------------------------------------------------------
    ReDim ArrList(-1 To iListCount - 1)
    iColumnCount = ctlList.ColumnCount

'
    For intRow = 0 To iListCount - 1
        sVal = ""
        For iColumn = 1 To iColumnCount 'Cобираем строку одного элемента списка
            sVal = sVal & ";" & ctlList.Column(iColumn - 1, intRow)
        Next iColumn
        
        sVal = Mid(sVal, 2) 'Удаляем первое вхождение ";"
        ArrList(intRow) = sVal 'Значение в массив!
        
        If ctlList.Selected(intRow) Then 'Если элемент выделен
            iPosStart = ctlList.ListIndex
            sStartName = sVal
            iPosEnd = iPosStart + iDirection 'Индекс эл. назначения
            
            For iColumn = 1 To iColumnCount 'Cобираем строку одного итема
                sEndName = sEndName & ";" & ctlList.Column(iColumn - 1, iPosEnd)
            Next iColumn
            sEndName = Mid(sEndName, 2)   'Удаляем первое вхождение  ";"
        End If
    Next intRow

'Меняем местами данные
    ArrList(iPosStart) = sEndName
    ArrList(iPosEnd) = sStartName
    
'Меняем RowSource
    sVal = Join(ArrList, ";")
    sVal = Mid(sVal, 2) 'удаляем первое ";"
    'Debug.Print "RowSource = " & sVal
    ctlList.RowSource = sVal

ListResort_End:
    On Error Resume Next
    Exit Sub

ListResort_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub ListResort.", _
        vbCritical, "Произошла ошибка!"
    'Debug.Print "ListResort_Line: " & Erl & "."
    Err.Clear
    Resume ListResort_End

End Sub

MSA-2007 и выше ( 39 kB) Пример