Отсортированный список !!!

Программирование на Visual Basic for Applications
Rom213
Новичок
Новичок
 
Сообщения: 36
Зарегистрирован: 24.09.2006 (Вс) 14:57

Отсортированный список !!!

Сообщение Rom213 » 26.09.2006 (Вт) 22:13

Народ здраствуйте !!!
Подскажите плиз. Тут такое дело: есть такой код


Код: Выделить всё
Private Sub CommandButton1_Click()
    Dim AllCells As Range, Cell As Range
    Dim NoDupes As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
   
'   The items are in A1:A105
    Set AllCells = Worksheets("ñêëàä").Range("name")
   
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell

'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
   
'   Add the sorted, non-duplicated items to a ListBox
    For Each Item In NoDupes
        UserForm1.ListBox1.AddItem Item
    Next Item
'   Show the UserForm
    UserForm1.Show
End Sub



Его назначение вывод списка в отсортированном варианте, только он выводит список в listbox, а мне надо что бы выводил в ячейки может кто скажет как переделать UserForm1.ListBox1.AddItem Item что бы так получилось


:-)


THK.

KL
Microsoft MVP
 
Сообщения: 483
Зарегистрирован: 30.10.2005 (Вс) 0:31
Откуда: Madrid

Сообщение KL » 26.09.2006 (Вт) 23:20

Попробуй так:

Код: Выделить всё
Private Sub CommandButton1_Click()
    Dim AllCells As Range, Cell As Range
    Dim NoDupes As New Collection
    Dim i As Long, j As Long, x As Long
    Dim Swap1, Swap2, Item
   
    Set AllCells = Worksheets("neeaa").Range("name")
   
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell

    On Error GoTo 0

    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i

    Application.ScreenUpdating=False
    For Each Item In NoDupes
        x = x + 1
        ActiveSheet.Cells(x, "D") = Item
    Next Item
    Application.ScreenUpdating=True
End Sub
Привет,
KL

Rom213
Новичок
Новичок
 
Сообщения: 36
Зарегистрирован: 24.09.2006 (Вс) 14:57

Сообщение Rom213 » 26.09.2006 (Вт) 23:34

вроде работает большое thk. буду добивать :-) дальше.

KL
Microsoft MVP
 
Сообщения: 483
Зарегистрирован: 30.10.2005 (Вс) 0:31
Откуда: Madrid

Сообщение KL » 27.09.2006 (Ср) 2:09

Прилагаю пример.
Вложения
Book1.xls
(43.5 Кб) Скачиваний: 56
Привет,
KL

uhm
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1597
Зарегистрирован: 02.12.2004 (Чт) 15:21

Сообщение uhm » 27.09.2006 (Ср) 9:53

Э-э, такая вещь, как расширенный фильтр с галочкой "только уникальные записи" + сортировка потом, вроде бы, заменяет весь указанный код, нет? :)
Быть... или не быть. Вот. В чём вопрос?

KL
Microsoft MVP
 
Сообщения: 483
Зарегистрирован: 30.10.2005 (Вс) 0:31
Откуда: Madrid

Сообщение KL » 27.09.2006 (Ср) 10:35

uhm писал(а):Э-э, такая вещь, как расширенный фильтр с галочкой "только уникальные записи" + сортировка потом, вроде бы, заменяет весь указанный код, нет? :)


Нет, ровно половину. Для того, чтобы заменить весь код нужно применить фильтр дважды + сортировка + перевод в массив (или переприсвоение свойства RowSource. И хотя решение через расширенный фильтр с точки зрения скорости намного эффективнее, оно относительно громоздкое (требует использования промежуточных рангов). Поэтому я обычно рекомендую расширенный фильтр от 10.000 строк и далее, т.к. до 10.000 строк обычно даже на слабом компе разница в скорости между кодом Уокенбаха и расширенным фильтром глазу незаметна ;-)
Привет,
KL

Rom213
Новичок
Новичок
 
Сообщения: 36
Зарегистрирован: 24.09.2006 (Вс) 14:57

Сообщение Rom213 » 27.09.2006 (Ср) 11:50

да что понаписывали то понаписывали :-).
Еще один вопосик в том комбобоксе который в примере можно ли что бы дни недели начинали вводиться с клавиатуры и высвечивалось их продолжение Я идиот! Убейте меня, кто-нибудь! :?:

:D

KL
Microsoft MVP
 
Сообщения: 483
Зарегистрирован: 30.10.2005 (Вс) 0:31
Откуда: Madrid

Сообщение KL » 27.09.2006 (Ср) 23:20

Rom213 писал(а):...в том комбобоксе который в примере можно ли что бы дни недели начинали вводиться с клавиатуры и высвечивалось их продолжение Я идиот! Убейте меня, кто-нибудь! :?:


А ты попробуй - может он уже это делает ;-)
Думаю, что тебе остается только добавить код обрабатывающий ошибки при вводе или использовать др. событие и установить свойство MatchRequired=True у ComBox1 как в приложенном файле.
Вложения
Book1.xls
(47 Кб) Скачиваний: 51
Привет,
KL

Rom213
Новичок
Новичок
 
Сообщения: 36
Зарегистрирован: 24.09.2006 (Вс) 14:57

Сообщение Rom213 » 27.09.2006 (Ср) 23:26

ок thk, вчера пробовал вводить он нехотел :-), а сгодня как нистранно все сделал. Наверняка не на то жал :-).


Вернуться в VBA

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 53

    TopList