Страницы: 1
RSS
Не работает выгрузка из массива в Combobox
 
Здравствуйте! У меня почему-то не работает код.
Макрос должен отобрать уникальные даты, сортировать их и занести готовые даты в Combobox. По коде, вроде бы, все должно работать, но нужного результата нет. Подскажите, пожалуйста, что тут не так. Плюс даты должны отображатся в таком формате "ddd dd.mm.yy h:mm". Спасибо!
Код
Option Explicit
Option Base 1
Sub Ynicom()
    Dim arrData() As Date, myDictionary As Object, myCell As Range, Sh7 As Worksheet, lLastRow7A As Long
        Set Sh7 = Лист7
        Set myDictionary = CreateObject("Scripting.Dictionary")
            lLastRow7A = Sh7.Cells(Rows.Count, 1).End(xlUp).Row
    
'Отбор уникальных значений из диапазона
        On Error Resume Next
            For Each myCell In Sh7.Range("A2:A" & lLastRow7A)
                myDictionary.Add CDate(myCell), CDate(myCell)
            Next
        On Error GoTo 0
    
        ReDim Preserve arrData(myDictionary.Count)
        arrData = myDictionary.Items
            SortAr arrData
            CmB_Date.List = arrData                                         'не заполняется комбобокс
            CmB_Date.Value = Format(CmB_Date.Value, "ddd dd.mm.yy h:mm")    'нужен такой формат дат в комбобоксе
End Sub
Sub SortAr(arr() As Date)
    Dim Temp As Date, i As Long, j As Long
        For j = 2 To UBound(arr)
            Temp = arr(j)
            For i = j - 1 To 1 Step -1
                If (arr(i) <= Temp) Then GoTo 10
                    arr(i + 1) = arr(i)
            Next i
            i = 0
10:         arr(i + 1) = Temp
        Next j
End Sub

 
Изменил название процедуры + убрал тип Date для массива и сортера - из словаря выгрузка ключей и итемов только в вариантные массивы.
Код
Private Sub UserForm_Initialize()
    Dim arrData(), myDictionary As Object, myCell As Range, Sh7 As Worksheet, lLastRow7A As Long
        Set Sh7 = Ëèñò7
        Set myDictionary = CreateObject("Scripting.Dictionary")
            lLastRow7A = Sh7.Cells(Rows.Count, 1).End(xlUp).Row
    
'Îòáîð óíèêàëüíûõ çíà÷åíèé èç äèàïàçîíà
        On Error Resume Next
            For Each myCell In Sh7.Range("A2:A" & lLastRow7A)
                myDictionary.Item(CDate(myCell.Value)) = CDate(myCell.Value)
            Next
        On Error GoTo 0
    
        ReDim Preserve arrData(myDictionary.Count - 1)
        arrData = myDictionary.Items()
            SortAr arrData
            CmB_Date.List = arrData                                         'íå çàïîëíÿåòñÿ êîìáîáîêñ
            CmB_Date.Value = Format(CmB_Date.Value, "ddd dd.mm.yy h:mm")    'íóæåí òàêîé ôîðìàò äàò â êîìáîáîêñå
End Sub
Sub SortAr(arr())
    Dim Temp As Date, i As Long, j As Long
        For j = 2 To UBound(arr)
            Temp = arr(j)
            For i = j - 1 To 1 Step -1
                If (arr(i) <= Temp) Then GoTo 10
                    arr(i + 1) = arr(i)
            Next i
            i = 0
10:         arr(i + 1) = Temp
        Next j
End Sub
Изменено: Anchoret - 08.09.2019 12:19:35
 
Anchoret, вроде все хорошо, только 2 "но",

1. Первая дата в комбобоксе стоит     6/5/2019  1:54:00 PM - это не по алфавиту
2. Формат дат в комбоксе должен быть "ddd dd.mm.yy h:mm", тоесть, как в столбце "А"
   CmB_Date.Value = Format(CmB_Date.Value, "ddd dd.mm.yy h:mm") - такая строка кода не изменяет, почему-то формата.
 
Даты, вообще-то, сортируются по дате, а не по алфавиту. И первая дата - это 5 июня, так-же, как и на листе.
В списке отображение дат зависит от региональных настроек.
Format(CmB_Date.Value, "ddd dd.mm.yy h:mm")  - это уже не дата, а текст.
Отобразить его в комбобоксе можно примерно так
Код
Private Sub CmB_Date_Change()
CmB_Date.Value = Format(CmB_Date.Value, "ddd dd.mm.yy h:mm")
End Sub
 
Цитата
RAN написал:
И первая дата - это 5 июня, так-же, как и на листе.
Да, на листе эта дата первая, - но и в списке она первая,  остальные даты сортированы по дате, кроме этой. Что нужно изменить, чтобы и эта дата была сортирована?
 
Ну, я бы начал с того, что выкинул строки
Код
Option Base 1
и
Код
ReDim Preserve arrData(myDictionary.Count)

И исправил цикл
Код
For j = 1 To UBound(arr)
 
Хорошо, буду разбиратся, - Спасибо всем за помощь!
Страницы: 1
Наверх