Доброго дня всем! Требуется отобрать уникальные значения из диапазона ячеек с формулами на другой лист этого документа. Использование расширенного фильтра не допускается, т.к. он работает только в текущем листе, не работает с результатом формул и при добавлении или изменении данных в этом диапазоне придётся заново все фильтровать. Где-то могу ошибаться-поправьте, пжлст.
Для примера приложил документ.
отобрать уникальные значения из "Лист 1" W3:W37 на лист "Данные" в столбец C.
Либо только: отобрать уникальные значения из "Лист 1" W3:W37 на лист "Сортировка" по двум критериям (тип дерева и вид материала). К примеру: значение ячейки из листа "Лист1" W8 скопируется в ячейку B3 на листе "Сортировка", т.к. это РЕЙКА из ДУБА. И т.д.
Доброго дня всем! Требуется отобрать уникальные значения из диапазона ячеек с формулами на другой лист этого документа. Использование расширенного фильтра не допускается, т.к. он работает только в текущем листе, не работает с результатом формул и при добавлении или изменении данных в этом диапазоне придётся заново все фильтровать. Где-то могу ошибаться-поправьте, пжлст.
Для примера приложил документ.
отобрать уникальные значения из "Лист 1" W3:W37 на лист "Данные" в столбец C.
Либо только: отобрать уникальные значения из "Лист 1" W3:W37 на лист "Сортировка" по двум критериям (тип дерева и вид материала). К примеру: значение ячейки из листа "Лист1" W8 скопируется в ячейку B3 на листе "Сортировка", т.к. это РЕЙКА из ДУБА. И т.д.al1025t01
Сделал через UDF, для листа "Сортировка". Потестите, а то некогда слегка
[vba]
Код
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Const MMax = 1000 Dim UnStr(MMax) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If R.Cells(i, 1) = S1 And R.Cells(i, 2) = S2 Then Found = False RC = R.Cells(i, R.Columns.Count) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 If M = N Then SSearch = RC Exit Function End If If M > MMax Then SSearch = "превышение макс. кол-ва уникальных записей, поправьте UDF SSearch" Exit Function End If End If End If Next i
End Function
[/vba]
стопэ, глюки
Сделал через UDF, для листа "Сортировка". Потестите, а то некогда слегка
[vba]
Код
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Const MMax = 1000 Dim UnStr(MMax) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If R.Cells(i, 1) = S1 And R.Cells(i, 2) = S2 Then Found = False RC = R.Cells(i, R.Columns.Count) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 If M = N Then SSearch = RC Exit Function End If If M > MMax Then SSearch = "превышение макс. кол-ва уникальных записей, поправьте UDF SSearch" Exit Function End If End If End If Next i
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Const MMax = 1000 Dim UnStr(MMax) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If Trim(R.Cells(i, 1)) = S1 And Trim(R.Cells(i, 2)) = S2 Then Found = False RC = Trim(R.Cells(i, R.Columns.Count)) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 UnStr(M) = RC If M = N Then SSearch = RC Exit Function End If If M > MMax Then SSearch = "превышение макс. кол-ва уникальных записей, поправьте UDF SSearch" Exit Function End If End If End If Next i
End Function
[/vba]
так, что ли ... проверяйте ...
[vba]
Код
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Const MMax = 1000 Dim UnStr(MMax) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If Trim(R.Cells(i, 1)) = S1 And Trim(R.Cells(i, 2)) = S2 Then Found = False RC = Trim(R.Cells(i, R.Columns.Count)) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 UnStr(M) = RC If M = N Then SSearch = RC Exit Function End If If M > MMax Then SSearch = "превышение макс. кол-ва уникальных записей, поправьте UDF SSearch" Exit Function End If End If End If Next i
Пока мэтры не напинали, поправлю хотя бы самую корявую корявость в коде
[vba]
Код
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Dim UnStr() As String ReDim UnStr(N) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If Trim(R.Cells(i, 1)) = S1 And Trim(R.Cells(i, 2)) = S2 Then Found = False RC = Trim(R.Cells(i, R.Columns.Count)) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 UnStr(M) = RC If M = N Then SSearch = RC Exit Function End If End If End If Next i
End Function
[/vba]
Пока мэтры не напинали, поправлю хотя бы самую корявую корявость в коде
[vba]
Код
Public Function SSearch(S1, S2 As String, R As Range, N As Integer) As String 'Ищет N-ю по порядку уникальную ячейку
Dim UnStr() As String ReDim UnStr(N) As String
M = 0 'Cчетчик уникальных значений
For i = 1 To R.Rows.Count 'Цикл по строкам If Trim(R.Cells(i, 1)) = S1 And Trim(R.Cells(i, 2)) = S2 Then Found = False RC = Trim(R.Cells(i, R.Columns.Count)) For j = 1 To M ' цикл по массиву уникальных строк If RC = UnStr(j) Then Found = True Exit For End If Next j If Not Found Then M = M + 1 UnStr(M) = RC If M = N Then SSearch = RC Exit Function End If End If End If Next i
abtextime, спасибо тебе. Сейчас подпиливаю документ и столкнулся с некоторыми проблемами. А именно: не работает скрипт отбора уникальных значений для "Дуб", "Дуб проп","Груша проп" на листе "Сортировка", хотя "Ясень" и "Клен" сортирует. Везде все сделано по аналогии с исходным документом. Да, и ещё я столбец "ДхШхТ" перенес в середину таблицы. В формуле диапазон поменял. Где-то я накосячил - не пойму.
abtextime, спасибо тебе. Сейчас подпиливаю документ и столкнулся с некоторыми проблемами. А именно: не работает скрипт отбора уникальных значений для "Дуб", "Дуб проп","Груша проп" на листе "Сортировка", хотя "Ясень" и "Клен" сортирует. Везде все сделано по аналогии с исходным документом. Да, и ещё я столбец "ДхШхТ" перенес в середину таблицы. В формуле диапазон поменял. Где-то я накосячил - не пойму.al1025t01
Использование расширенного фильтра не допускается, т.к. он работает только в текущем листе, не работает с результатом формул
Если запускать расширенный фильтр с листа "Данные" и исходный диапазон прописать на Лист1 (например, вот так: Лист1!W1:W9999), то все прекрасно работает. И ему без разницы - формулы там или значения. Диапазон условий можно вообще не заполнять. Скрин см. в файле на листе "Данные". Все это можно сделать макросом [vba]
Код
Sub Макрос1() Sheets("Лист1").Range("W1:W999").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("C1"), Unique:=True End Sub
[/vba]
А лист "Сортировка" можно заполнить формулой массива (вводится одновременным нажатием Контрл Шифт Ентер)
Использование расширенного фильтра не допускается, т.к. он работает только в текущем листе, не работает с результатом формул
Если запускать расширенный фильтр с листа "Данные" и исходный диапазон прописать на Лист1 (например, вот так: Лист1!W1:W9999), то все прекрасно работает. И ему без разницы - формулы там или значения. Диапазон условий можно вообще не заполнять. Скрин см. в файле на листе "Данные". Все это можно сделать макросом [vba]
Код
Sub Макрос1() Sheets("Лист1").Range("W1:W999").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("C1"), Unique:=True End Sub
[/vba]
А лист "Сортировка" можно заполнить формулой массива (вводится одновременным нажатием Контрл Шифт Ентер)
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
