Excel VBA: сортировка диапазона с использованием массива перестановок в качестве ключа

Question

Я бы хотел отсортировать диапазон, используя перестановку, хранящуюся в массиве. Я пробовал что-то вроде этого:

Sub PermSort()
  Dim Perm() As Variant
  Perm = Array(1, 6, 7, 8, 5, 2, 4, 3)
  Range("A1:A8").Sort Key1:=Perm, order1:=xlAscending
End Sub

но это не работает, поскольку ожидается, что Key1 будет Range.
Можно ли как-то использовать метод build in .Sort?

Answer 1

Отсюда:

Язык VBA не поддерживает сортировку значений, хранящихся в массиве. Один из методов, который можно использовать для сортировки массивов, - это поместить данные на лист, отсортировать данные на листе и затем прочитать значения из листа в массив. Другой метод сортировки массивов - использование алгоритма QSort для сортировки массива на месте. На этой странице описаны оба метода с различными вариантами метода QSort.

НТН!

PS:

Код для первого метода:

Sub SortViaWorksheet()
    Dim Arr(1 To 5) As String ' this is the array to be sorted
    Dim WS As Worksheet ' temporary worksheet
    Dim R As Range
    Dim N As Long

    ' fill up the array with some
    ' aribtrary values.
    Arr(1) = "aaa"
    Arr(2) = "zzz"
    Arr(3) = "mmm"
    Arr(4) = "ttt"
    Arr(5) = "bbb"

    Application.ScreenUpdating = False

    ' create a new sheet
    Set WS = ThisWorkbook.Worksheets.Add

    ' put the array values on the worksheet
    Set R = WS.Range("A1").Resize(UBound(Arr) - LBound(Arr) + 1, 1)
    R = Application.Transpose(Arr)

    ' sort the range
    R.Sort key1:=R, order1:=xlAscending, MatchCase:=False

    ' load the worksheet values back into the array
    For N = 1 To R.Rows.Count
        Arr(N) = R(N, 1)
    Next N

    ' delete the temporary sheet
    Application.DisplayAlerts = False
    WS.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    ' test/debug/confirmation
    For N = LBound(Arr) To UBound(Arr)
        Debug.Print Arr(N)
    Next N   
End Sub  

Для второго есть стандартная процедура Qsort. Вы можете скачать его с оригинального сайта.