Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 35767
Главная » Готовые решения » VBA » Полезные приёмы

Сортировки массивов. Сортировка Шелла.
24.10.2013, 23:49

Sub example_01() '1-мерный массив
With Sheets("Sheet1")
 With .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
 .Value = Application.Transpose(ShellSort11(Application.Transpose(.Value)))
 End With
End With
End Sub
Function ShellSort11(x) '*** для 1-мерного массива
Dim Limit As Long, Switch As Long, i As Long, j As Long
Dim tmp
j = (UBound(x) - LBound(x) + 1) \ 2
Do While j > 0
 Limit = UBound(x) - j
 Do
 Switch = LBound(x) - 1
 For i = LBound(x) To Limit
 If x(i) > x(i + j) Then 'по возрастанию
' If x(i) < x(i + j) Then 'по убыванию
 tmp = x(i): x(i) = x(i + j)
 x(i + j) = tmp: Switch = i
 End If
 Next
 Limit = Switch - j
 Loop While Switch >= LBound(x)
 j = j \ 2
Loop
ShellSort11 = x
End Function
Sub example_02() '2-мерный массив
Dim tm!: tm = Timer
With Sheets("Sheet1")
 With .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row)
 .Value = ShellSort22(.Value, 2)
 End With
End With
End Sub
Function ShellSort22(x, k As Long) '*** сортируем 2-мерный массив x по столбцу k
Dim Limit As Long, Switch As Long, i&, j&, u&
Dim ubx&, t
ubx = UBound(x, 2): j = (UBound(x) - LBound(x) + 1) \ 2
Do While j > 0
 Limit = UBound(x) - j
 Do
 Switch = LBound(x) - 1
 For i = LBound(x) To Limit
 If x(i, k) > x(i + j, k) Then 'по возрастанию
' If x(i, k) < x(i + j, k) Then 'по убыванию
 For u = 1 To ubx
 t = x(i, u)
 x(i, u) = x(i + j, u)
 x(i + j, u) = t
 Next
 Switch = i
 End If
 Next
 Limit = Switch - j
 Loop While Switch >= LBound(x)
 j = j \ 2
Loop: ShellSort22 = x
End Function
Добавил: nilem |
Просмотров: 2760 | Рейтинг: 5.0/1
Всего комментариев: 2
0   Спам
1    RAN   (13.08.2015 16:15)
   Улучшайзинг
Function ShellSort22(x, Optional k As Long = 1, Optional reg As Boolean = True, Optional ord As Boolean = True)
'*** сортируем 2-мерный массив x по столбцу k
Dim Limit As Long, Switch As Long, i&, j&, u&
Dim ubx&, t
ubx = UBound(x, 2): j = (UBound(x) - LBound(x) + 1) \ 2
Do While j > 0
Limit = UBound(x) - j
Do
Switch = LBound(x) - 1
For i = LBound(x) To Limit
If ord Then  'по возрастанию
If reg Then
If UCase$(x(i, k)) > UCase$(x(i + j, k)) Then GoSub sort_  'с учетом регистра
Else
If x(i, k) > x(i + j, k) Then GoSub sort_  'без учета регистра
End If
Else  'по убыванию
If reg Then
If UCase$(x(i, k)) < UCase$(x(i + j, k)) Then GoSub sort_  'с учетом регистра
Else
If x(i, k) < x(i + j, k) Then GoSub sort_  'без учета регистра
End If
End If
Next
Limit = Switch - j
Loop While Switch >= LBound(x)
j = j \ 2
Loop
ShellSort22 = x
Exit Function
sort_:
For u = 1 To ubx
t = x(i, u)
x(i, u) = x(i + j, u)
x(i + j, u) = t
Next
Switch = i
Return
End Function

0   Спам
2    RAN   (21.08.2015 19:24)
   Убедительно прошу Администрацию сайта удалить данный комментарий вместе с комментарием №1.
Обязуюсь впредь не оставлять комментариев на страницах сайта.

Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!