Страницы: 1
RSS
Выборка уникальных значений с условием
 
Уважаемые гуру форума, подскажите как решить небольшую проблему. Ситуация следующая в: в ячейках А1:А5 находятся даты, в ячейках В1:В5 имеется признак отбора (в примере буква В), требуется выбрать уникальные даты. Сейчас эта проблема успешно решается следующим кодом:
Код
Private Sub CommandButton1_Click() 'выборка уникальных дат
    Range("C2:C4").ClearContents
    Dim vItem As Variant, avArr As Variant, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
        With New Collection
            On Error Resume Next
            For Each vItem In ActiveSheet.Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value 'определяет последнюю заполненную ячейку в столбце A
                .Add vItem, CStr(vItem)
                If Err = 0 Then
                    li = li + 1: avArr(li, 1) = vItem
                Else: Err.Clear
                End If
            Next
        End With
    If li Then [C2].Resize(li).Value = avArr
End Sub
Но теперь потребовалось, чтобы в отборе участвовали только те ячейки, рядом с которыми отсутствует признак отбора, т.е. в данном случае отобраться должны только даты 02.01.2015 и 03.01.2015 ,т.к. все ячейки с датой 01.01.2015 имеют признак в соответствующих ячейках. Признак, разумеется, может быть (или не быть) в любых ячейках указанного диапазона. Что нужно дописать в коде, чтобы было так? Заранее спасибо всем откликнувшимся.
 
Странно...
Этим кодом отбираются только уникальные даты из столбца А, признак из В никак не участвует в отборе.
Кому решение нужно - тот пример и рисует.
 
Это я знаю, в том то и вопрос чтобы код доработать (просто раньше нужды в дополнительном отборе не было и код подходил)
Изменено: plex - 01.04.2015 10:40:33
 
с минимальными изменениями:
Код
Private Sub CommandButton1_Click() 'выборка уникальных дат
    Range("C2:C4").ClearContents
    Dim vItem As Variant, avArr As Variant, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
        With New Collection
            On Error Resume Next
            For Each vItem In ActiveSheet.Range("A2", Cells(Rows.Count, 1).End(xlUp)) 'определяет последнюю заполненную ячейку в столбце A
                If vItem.Offset(, 1) <> "В" Then
                .Add vItem, CStr(vItem)
                If Err = 0 Then
                    li = li + 1: avArr(li, 1) = vItem
                Else: Err.Clear
                End If
                End If
            Next
        End With
    If li Then [C2].Resize(li).Value = avArr

End Sub
Живи и дай жить..
 
Не могу файл проверить - 2003...
В чём проблема проверить соседнюю ячейку например так:
Код
If vItem.Offset(, 1) = "B" Then

Или переписать код на использование номеров строк и столбцов.

И кстати расточительно объявлять массив на миллион строк, когда нужны всего 3-4.
 
Слэн, Hugo, спасибо за ответы сейчас буду проверять. Hugo, в реальном файле максимальное количество строк может быть 5000, как Вы считаете, в таком случае правильнее указывать конкретный диапазон или высчитывать последнюю заполненную ячейку? (это ни в коей степени не сарказм, это вопрос для моих знаний)
 
Если не будет больше 5000 - то практически разницы в скорости обработки не заметите. Ну разве что замерять обработку 10 и 5000.
Но в общем лучше высчитывать - а то вдруг будет 5001?
 
вот с экономным резервированием:
Код
Private Sub CommandButton1_Click() 'выборка уникальных дат
    Range("C2:C4").ClearContents
    Dim vItem As Variant, avArr As Variant, li As Long
        With New Collection
            On Error Resume Next
            
            For Each vItem In ActiveSheet.Range("A2", Cells(Rows.Count, 1).End(xlUp)) 'определяет последнюю заполненную ячейку в столбце A
                If vItem.Offset(, 1) <> "В" Then
                .Add vItem, CStr(vItem)
                End If
            Next
            ReDim avArr(1 To .Count, 1 To 1)
            For li = 1 To .Count
              avArr(li, 1) = .Item(li)
            Next li
            
        End With
    If ubound(avArr) Then [C2].Resize(li - 1).Value = avArr

End Sub


Изменено: Слэн - 01.04.2015 11:16:09
Живи и дай жить..
 
поправил код выше
Живи и дай жить..
Страницы: 1
Наверх