Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Извлечение уникальных значений, Помогите доработать макрос
 
#1
09.04.2015 19:43:49
Уважаемые гуру форума, подскажите как следует доработать макрос. Ситуация такая: для извлечения уникальных значений давно пользуюсь макросом, найденном на просторах сети:
Код
Private Sub CommandButton1_Click()
    Range("B2:B11").ClearContents
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
        With New Collection
            On Error Resume Next
            For Each vItem In Sheets("Приход").Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
                .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 [B2].Resize(li).Value = avArr
End Sub
Все работает, но сейчас, для использования отобранных данных в формуле, потребовалась сделать так, чтобы те ячейки в диапазоне B2:B11, которые оказались не заполнены данными, заполнялись, ну скажем 0 (как в примере). В VBA я только первые шаги пытаюсь делать, так что приспособить макрос к своей задаче я еще могу, а вот с доработкой пока (надеюсь) проблема:oops:. Заранее спасибо всем откликнувшимся.
 
 
 
#2
09.04.2015 20:08:43
Как-то так
Код
Private Sub CommandButton1_Click()
    Set Rng = Range("B2:B11")
    Rng.ClearContents
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
        With New Collection
            On Error Resume Next
            For Each vItem In Sheets("Приход").Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
                .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 [B2].Resize(li).Value = avArr
    Range("B" & 2 + li & ":B" & Rng.Rows.Count).Value = 0
End Sub
 
 
 
#3
09.04.2015 20:12:59
Здравствуйте.
Добавьте в конец еще 2 строки кода:
Код
    li = Cells(Rows.Count, 2).End(xlUp).Row 'определяем наибольший номер строки, заполненные уникальными значениями
    Range("b" & li + 1).Resize(11 - li, 1) = 0 'через метод Resize изменяем диапазон до 11 строки и присваиваем значение 0 
'засада может быть в чем: если заполнены уникальными будут все 11 строк, или больше - вызовет ошибку.
Кому решение нужно - тот пример и рисует.
 
 
 
#4
09.04.2015 20:30:53
MBT, Ваш вариант работает почти правильно: 0 вставляются до предпоследней строчки диапазона. А вот вариант Пытливого отрабатывает как надо. Спасибо Вам огромное.
 
 
 
Страницы: 1
Наверх