Работаю с большим кол-вом данных (версия Excel 2021), необходимо решить задачу: В прикрепленном файле в столбце "Результат" собран список уникальных значений из предыдущих 6-ти столбцов, формулами типа: ввести в G2
=ЕСЛИОШИБКА(ИНДЕКС($A$2:$F$10000;ОКРВНИЗ((МАКС((СЧЁТЕСЛИ($G$1:G1;$A$2:$F$10000)=0)*((СТРОКА($A$2:$F$10000)-2)*6+СТОЛБЕЦ($A$2:$F$10000)))-1)/6;1)+1;(ОСТАТ(МАКС((СЧЁТЕСЛИ($G$1:G1;$A$2:$F$10000)=0)*((СТРОКА($A$2:$F$10000)-2)*6+СТОЛБЕЦ($A$2:$F$10000)))-1;6)+1));"") или подобные ей
задачу решить не помогут, т.к. кол-во столбцов может быть много, строк более 10000, таблица начинает сильно тормозить, данные в первых 6-ти столбцах, как в примере, будут меняться автоматически и хотелось бы найти возможно макрос-функцию или простую формулу как типа "=УНИК" но чтоб работала на много столбцов, для получения автоматического единого уникального списка в одном столбце (а в идеале еще и чтоб в ней была встроена при необходимости функция "=СОРТ", ну если возможно )
Так же читал про функцию "=TOCOL", но в моей лицензированной версии Excel 2021 ее тоже нет, но есть приобретенный PLEX. Еще задавал вопрос в чат Джи Пи Ти, на что был получен ответ: ввести в G1 формулу: "=UNIQUE(FILTER({A:A; B:B; C:C; D:D; E:E; F:F}, {A:A; B:B; C:C; D:D; E:E; F:F}<>""))", конечно поменял эту формулу на "=УНИК(ФИЛЬТР....". менял запятые на точки с запятыми, пробовал вставлять точки с запятыми перед знаками <> - формула не работает. Может кто подскажет как решить данный вопрос (можно прямо в моем примере ), за ранее благодарю.
Добрый день сделал запрос через Power Query. Если в именованный диапазон листа 1 добавить ваши данные и нажать кнопку обновить, листа "Результат", то уникальный данные со всех столбцов появится в столбце "результат" .
Sub AllUnique()
Dim arr()
Dim iKey, iTmp
With Worksheets("Лист1")
arr = Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
For Each iKey In arr
If Not IsEmpty(iKey) Then iTmp = .Item(iKey)
Next
Worksheets("Лист1").Range("I2").Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub
Ограничения: 1. Последняя строка с данными определяется по столбцу A 2. Диапазон исходных столбцов должен быть непрерывным
Цитата
Максим Кухальский написал: для получения автоматического единого уникального списка в одном столбце.
Sanja, Спасибо, а можно его повесить допустим когда вносится любое изменение в книге на любом листе? или это сильно затормозит файл, если нет, может подскажете строчку?
Максим Кухальский написал: когда вносится любое изменение в книге на любом листе
Вы сами этого хотели) В модуль ЭтаКнига
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Call AllUnique
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
Sanja, Добавил еще одну функцию в модуль, т.к. при изменении данных в 6-столбцах по кол-ву строк в меньшую сторону, старые данные не удаляются, а остаются:
Sub Удаление_столбца_уникальных() Columns("I:I").Select Selection.ClearContents End Sub
Потом дописал в Ваш код, в модуль ЭтаКнига
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False Application.EnableEvents = False Call Удаление_столбца_уникальных Call AllUnique Application.EnableEvents = True Application.ScreenUpdating = True End Sub
Вот только как дописать, чтоб завершенным действием было такое чтоб, выделенная ячейка оставалась там, где было внесено последнее изменение перед запуском этого макроса?)) или можно попроще что придумать?
Сначала она очищает столбец с результатами, потом закидывает уникальные, если в книге есть еще листы и вы будете на них, то можно дописать в конце Sheets("Нужный лист").Select Range("нужная ячейка").Select
А затея "при любом изменении в книге" запускать данный макрос была плохая идея, нужно выбрать подходящее событие. полный код:
Sub AllUnique() Sheets("Лист1").Select 'переключаемся на нужный лист Columns("I:I").Select ' выделяем столбец с результатами Selection.ClearContents 'очищаем его Dim arr() Dim iKey, iTmp With Worksheets("Лист1") ' Лист1 - вкладка где нужно искать уникальные arr = Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value 'диапазон столбцов для выдергивания уникальных End With With CreateObject("Scripting.Dictionary") For Each iKey In arr If Not IsEmpty(iKey) Then iTmp = .Item(iKey) Next Worksheets("Лист1").Range("I2").Resize(.Count) = Application.Transpose(.Keys) ' адрес результата End With Sheets("Лист1").Select 'переключаемся на выбранный лист Range("G1").Select 'ну и к примеру выделяем нужную ячейку End Sub
Еще раз огромное спасибо, очень помогли, файл во вложении.