Cортировка массива VBA

Пользователь

Сообщений: 243 Регистрация: 13.09.2013

15.02.2019 12:30:35

Доброго дня!

Есть код Quicksort для сортировки одномерного массива, взял с mdsn

Код

Sub QuickSort(arr, Lo As Long, Hi As Long)
  Dim varPivot As Variant
  Dim varTmp As Variant
  Dim tmpLow As Long
  Dim tmpHi As Long
  tmpLow = Lo
  tmpHi = Hi
  varPivot = arr((Lo + Hi) \ 2)
  Do While tmpLow <= tmpHi
    Do While arr(tmpLow) < varPivot And tmpLow < Hi
      tmpLow = tmpLow + 1
    Loop
    Do While varPivot < arr(tmpHi) And tmpHi > Lo
      tmpHi = tmpHi - 1
    Loop
    If tmpLow <= tmpHi Then
      varTmp = arr(tmpLow)
      arr(tmpLow) = arr(tmpHi)
      arr(tmpHi) = varTmp
      tmpLow = tmpLow + 1
      tmpHi = tmpHi - 1
    End If
  Loop
  If Lo < tmpHi Then QuickSort arr, Lo, tmpHi
  If tmpLow < Hi Then QuickSort arr, tmpLow, Hi
End Sub

Он предназначен для одномерного массива. У меня двухмерный массив, возможно ли модифицировать данный код, чтобы он сортировал так же по одному/первому столбцу, но изменял 2?

Anchoret

Пользователь

Сообщений: 1065 Регистрация: 01.01.1970

Anchoret

15.02.2019 13:01:53

Это не обязательно. Достаточно сделать его сортирующим по индексам и возвращающим массив индексов первичного массива по сортируемому столбцу этого массива. А потом уже сборка итогового массива по индексам.
Да, и для двумерного массива при наличии в этом массиве дублей QuickSort не очень - поедет относительное смещение индексов соседних столбцов на дублях.

Что в исходном массиве?

Изменено: Anchoret - 15.02.2019 13:06:39

ALFA

Пользователь

Сообщений: 243 Регистрация: 13.09.2013

15.02.2019 13:46:24

Вот пример, есть два столбца:

1 столбец - регион, значения могут повторяться
2 столбец - имя

Мне необходимо добиться того чтобы список был отсортирован по первому столбцу, т.е. чтобы имена из одного региона шли друг за другом. Оригинальный список может быть от 1500 строк.

Прикрепленные файлы

пример.xlsx (8.51 КБ)

ALFA

Пользователь

Сообщений: 243 Регистрация: 13.09.2013

15.02.2019 15:05:49

Докрутил я немного Quicksort, работает(сортирует массив из двух столбцов, по первому), на счет скорости мне пока непонятно, проверю как получу большие исходные данные.

Прикрепленные файлы

пример.xlsm (19.28 КБ)

Изменено: ALFA - 15.02.2019 18:15:27

Nordheim Пользователь Сообщений: 3154 Регистрация: 18.04.2017	#5 15.02.2019 15:54:04 Писал как то под определенную задачу класс с сортировкой одно и многомерных массивов, посмотрите может подойдет. Прикрепленные файлы QuickSort.xlsm (15.72 КБ) "Все гениальное просто, а все простое гениально!!!"

Anchoret

Пользователь

Сообщений: 1065 Регистрация: 01.01.1970

Anchoret

15.02.2019 19:55:22

ALFA, для 1500-5000 строк особой разницы и не почуствуете)
Вариант с числовым сортером, хотя для него сфера применения массивы от 100к строк (как впрочем и для QuickSort'a):

Скрытый текст

Код

Sub test()
Dim arr(), dd&(), a&, b&, iArr()
arr = [A1].CurrentRegion.Value
ReDim dd(1 To UBound(arr))
For a = 1 To UBound(arr): dd(a) = arr(a, 1): Next
NumSortIdx dd()
ReDim iArr(1 To UBound(arr), 1 To UBound(arr, 2))
For a = 1 To UBound(dd)
  For b = 1 To UBound(arr, 2): iArr(a, b) = arr(dd(a), b): Next
Next
[A1].Resize(UBound(arr), UBound(arr, 2)).Value = iArr
End Sub
'-------------
Sub NumSortIdx(InArr&(), Optional ByVal kf! = 0.5)
Dim arr(), aa&(), bb&(), a&, b&, c&, x&, z&
Dim iMin#, iMax#
iMax = UBound(InArr) / 5: iMin = iMax
ReDim Preserve aa(LBound(InArr) To UBound(InArr))
For a = LBound(aa) To UBound(aa)
  Select Case InArr(a)
    Case Is > iMax: iMax = InArr(a)
    Case Is < iMin: iMin = InArr(a)
  End Select
Next
ReDim arr(1 To (iMax - iMin) * kf)
z = (iMax - iMin) / ((iMax - iMin) * kf)
For a = LBound(aa) To UBound(aa)
  If InArr(a) > 0 Then
    x = InArr(a) / z
    If x < 1 Then x = 1
    If x > UBound(arr) Then x = UBound(arr)
  Else: x = 1
  End If
  arr(x) = arr(x) + 1
Next
For a = LBound(aa) To UBound(aa)
  If InArr(a) > 0 Then
    x = InArr(a) / z
    If x < 1 Then x = 1
    If x > UBound(arr) Then x = UBound(arr)
  Else: x = 1
  End If
  If Not IsArray(arr(x)) Then
    ReDim bb(1 To arr(x) + 1): bb(1) = 1
    bb(2) = a: arr(x) = bb
  Else
    bb = arr(x): bb(1) = bb(1) + 1
    bb(bb(1) + 1) = a: arr(x) = bb
  End If
Next
z = LBound(InArr)
For a = 1 To UBound(arr)
  If IsArray(arr(a)) Then
    bb = arr(a): x = z
    If bb(1) = 1 Then
      aa(z) = bb(2)
    Else
      aa(z) = bb(2)
      For b = 3 To bb(1) + 1
        z = z + 1: c = z
        Do While InArr(aa(c - 1)) > InArr(bb(b))
          aa(c) = aa(c - 1): c = c - 1
          If c = x Then Exit Do
        Loop
        aa(c) = bb(b)
      Next
    End If
    z = z + 1
  End If
Next
InArr = aa: Erase arr: Erase aa: Erase bb
End Sub

Прикрепленные файлы

Копия пример (1).xlsm (17.25 КБ)

Изменено: Anchoret - 15.02.2019 19:59:09

Inexsu

Пользователь

Сообщений: 760 Регистрация: 29.06.2017

16.02.2019 08:58:48

Привет!

Цитата
ALFA написал: проверю как получу большие исходные данные.

Всем тем, кто не написал себе макрос размножения данных.

Прикрепленные файлы

InExSu Диапазон размножить.xlsb (21.15 КБ)

Сравнение прайсов, таблиц - без настроек