Автофильтр по значениям из буфера обмена

[Ezoptron]

Здравствуйте.
Помогите, пожалуйста, решить следующую задачу в кальке:
На листе включён автофильтр. Необходимо взять из буфера обмена несколько значений и отфильтроваться по ним в столбце таблицы, где находится курсор. В экселе эта задача решается элементарно, а тут я столкнулся с кучей сложностей. И гуглил, и нейросети спрашивал, но ничего работающего, как надо, не нашёл.

Вот пример кода, который работает, но не совсем правильно. Он вместо того, чтобы устанавливать фильтр, скрывает ненужные строки:

Код Выделить Развернуть

Sub FilterByClipboardData
    Dim oDoc As Object
    Dim oSheet As Object
    Dim oCell As Object
    Dim oClipboard As Object
    Dim sData As String
    Dim aData() As String
    Dim oFilterDesc As Object
 
 GlobalScope.BasicLibraries.loadLibrary("ScriptForge")
 
    ' Получаем текущий документ и активный лист
    oDoc = ThisComponent
    oSheet = oDoc.CurrentController.ActiveSheet
 
    ' Получаем данные из буфера обмена
    oClipboard = CreateUnoService("com.sun.star.datatransfer.clipboard.SystemClipboard")
    Dim aTransferable As Object
    aTransferable = oClipboard.getContents()
    Dim aFlavor As New com.sun.star.datatransfer.DataFlavor
    aFlavor.MimeType = "text/plain;charset=utf-16"
    sData = aTransferable.getTransferData(aFlavor)
   
    ' Разделяем данные по переносам строк
    aData = Split(sData, Chr(10))
 
    ' Удаляем пробелы и пустые строки, сохраняем уникальные значения
    Dim oUniqueDict As Variant
    oUniqueDict = CreateScriptService("Dictionary")
   
    Dim i As Integer
    For i = LBound(aData) To UBound(aData)
        aData(i) = Trim(aData(i))
        If aData(i) <> ""  And Not oUniqueDict.Exists(aData(i)) Then
                  oUniqueDict.add(aData(i), 0)
        End If
    Next i

 
    ' Преобразуем ключи словаря обратно в массив
    Dim aUniqueData() As Variant
    Dim oKeys As Variant
    oKeys = oUniqueDict.Keys
    oSelection = ThisComponent.CurrentController.getSelection()
    iCol = oSelection.CellAddress.Column
 
    ' Создаем фильтр
    oFilterDesc = oSheet.CreateFilterDescriptor(True)
    With oFilterDesc
        .ContainsHeader = True
        .UseRegularExpressions = True
        .FilterFields = Array(CreateFilterField(iCol, join(oKeys(), "|")))
    End With
 oSheet.AutoFilter = True
    ' Применяем фильтр
    oSheet.filter(oFilterDesc)
End Sub
 '______________________________________________________________________________________________________________
' Функция для создания поля фильтра
Function CreateFilterField(nColumn As Long, sCriteria As String) As Object
    Dim oField As Object
    oField = CreateUnoStruct("com.sun.star.sheet.TableFilterField")
    oField.Field = nColumn
    oField.IsNumeric = False
    oField.Operator = com.sun.star.sheet.FilterOperator.EQUAL
    oField.StringValue = sCriteria
    CreateFilterField = oField
End Function


[bigor]

пример кода, который работает

у меня он вываливается в ошибку на этой строке oSheet.AutoFilter = True
Здесь более менее рабочий код фильтра с пояснениями от sokol92
 

[Ezoptron]

у меня он вываливается в ошибку на этой строке oSheet.AutoFilter = True

забыл удалить. просто удалите.

[bigor]

Удалил, отработал как вы описали. Мои мысли по этому поводу, вы объявили фильтр как

Код Выделить Развернуть

oFilterDesc = oSheet.CreateFilterDescriptor(True) и он фильтрует всю страницу, в примере по ссылке, фильтр применен к диапазону, и фильтрует нужные данные

[Ezoptron]

фильтр применен к диапазону

В примере указан конкретный диапазон, а хочется сделать универсальный макрос для фильтрации в любом файле, где включён автофильтр, по любым диапазонам.

Вот пример макроса на VBA, который делает то, что мне нужно:

Код Выделить Развернуть

Sub Фильтр_буфер()
On Error Resume Next
Dim i As Integer
Dim Test As String
Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject

clipboard.GetFromClipboard
Test = clipboard.GetText

Test = Replace(Test, Chr(13), "@%$")
Test = Trim(WorksheetFunction.Clean(Test))

Dim ab() As String
ab = Split(Test, "@%$")
ReDim Preserve ab(UBound(ab) - 1)
ActiveSheet.UsedRange.AutoFilter Field:=Selection.Column, Criteria1:=ab, Operator:= _
    xlFilterValues
End Sub


[bigor]

Ну так по ссылке все есть

Код Выделить Развернуть

REM  *****  BASIC  *****

Sub FilterByClipboardData
    Dim oDoc As Object
    Dim oSheet As Object
    Dim oCell As Object
    Dim oClipboard As Object
    Dim sData As String
    Dim aData() As String
    Dim oFilterDesc As Object
 
 GlobalScope.BasicLibraries.loadLibrary("ScriptForge")
 
    ' Получаем текущий документ и активный лист
    oDoc = ThisComponent
    oSheet = oDoc.CurrentController.ActiveSheet
 
    ' Получаем данные из буфера обмена
    oClipboard = CreateUnoService("com.sun.star.datatransfer.clipboard.SystemClipboard")
    Dim aTransferable As Object
    aTransferable = oClipboard.getContents()
    Dim aFlavor As New com.sun.star.datatransfer.DataFlavor
    aFlavor.MimeType = "text/plain;charset=utf-16"
    sData = aTransferable.getTransferData(aFlavor)
   
    ' Разделяем данные по переносам строк
    aData = Split(sData, Chr(10))
 
    ' Удаляем пробелы и пустые строки, сохраняем уникальные значения
    Dim oUniqueDict As Variant
    oUniqueDict = CreateScriptService("Dictionary")
   
    Dim i As Integer
    For i = LBound(aData) To UBound(aData)
        aData(i) = Trim(aData(i))
        If aData(i) <> ""  And Not oUniqueDict.Exists(aData(i)) Then
                  oUniqueDict.add(aData(i), 0)
        End If
    Next i

 
    ' Преобразуем ключи словаря обратно в массив
    Dim aUniqueData() As Variant
    Dim oKeys As Variant
    oKeys = oUniqueDict.Keys
    oSelection = ThisComponent.CurrentController.getSelection()
    iCol = oSelection.CellAddress.Column
 
    ' Создаем фильтр
    oDBRange=GetSheetFilterDBRange(oSheet)
    If Not (oDBRange Is Nothing) Then
    If oDBRange.AutoFilter Then
    oFilterDesc=oDBRange.ReferredCells.createFilterDescriptor(true)
   
    With oFilterDesc
        .ContainsHeader = True
        .UseRegularExpressions = True
        .FilterFields = Array(CreateFilterField(iCol, join(oKeys(), "|")))
    End With
   
    oDBRange.ReferredCells.filter(oFilterDesc)
    end if
  end if 
 
End Sub
 '______________________________________________________________________________________________________________
' Функция для создания поля фильтра
Function CreateFilterField(nColumn As Long, sCriteria As String) As Object
    Dim oField As Object
    oField = CreateUnoStruct("com.sun.star.sheet.TableFilterField")
    oField.Field = nColumn
    oField.IsNumeric = False
    oField.Operator = com.sun.star.sheet.FilterOperator.EQUAL
    oField.StringValue = sCriteria
    CreateFilterField = oField
End Function

' Возвращает DataBaseRange для автофильтра листа или Nothing.
Function GetSheetFilterDBRange(Byval oSheet As Object) as Object
  Dim i as Long, oDoc As Object
  GetSheetFilterDBRange=Nothing
  oDoc=oSheet.Drawpage.Forms.Parent
  i=oSheet.RangeAddress.Sheet
  With oDoc.getPropertyValue("UnnamedDatabaseRanges")
    If .hasByTable(i) Then GetSheetFilterDBRange=.getByTable(i)
  End With
End Function

[Ezoptron]

Ну так по ссылке все есть

Я вкатываюсь в ЛибреОфис с нуля, поэтому мне пока вообще не очевидны какие-то возможно очевидные вещи.Пока я тупо в шоке )
Ваш код работает. Это круто. А можно ли теперь в уже отфильтрованных строках отфильтроваться дальше по следующему полю, а потом по следующему?

[economist]

Я вкатываюсь в ЛибреОфис с нуля, поэтому мне пока вообще не очевидны какие-то возможно очевидные вещи.Пока я тупо в шоке )
Ваш код работает. Это круто. А можно ли теперь в уже отфильтрованных строках отфильтроваться дальше по следующему полю, а потом по следующему?

Это все, включая "автофильтр" по вставленному в яч. содержимому буфера обмена и последовательной фильтрации следующих полей уже наглядно реализовано в штатном функционале Данные - Еще...- Расширенный фильтр, одинаково работающему и в Calc, и в Excel (без использования макросов) и хорошо описанному в справке, с картинками.

Макросы нужны для того, что штатный функционал не умеет или делает неудобно.

[Ezoptron]

Макросы нужны для того, что штатный функционал не умеет или делает неудобно.

Ну вот я сейчас пытаюсь решить 3 задачи, жизненно необходимые для работы, которые в экселе я решил макросами:
1. Фильтр по значениям из буфера (в данной ветке).
2. Фильтр по значению активной ячейки (по аналогии с п.1). В экселе можно хотя бы правой кнопкой на ячейке тыкнуть и выбрать в меню, здесь я этого не нашёл.
3. Снятие всех фильтров (решена в другой ветке). В экселе кнопка в ленте, здесь нужен отдельный макрос.

[bigor]

В экселе кнопка в ленте, здесь нужен отдельный макрос.

я как то не много работаю с фильтрами, но бегло просмотрев меню, нашел 2 кнопки удалить фильтр и скрыть фильтр. Потыкав первую увидел, что скрытые фильтром данные показываются, вторая скрывает треуголички фильтра

[Ezoptron]

я как то не много работаю с фильтрами, но бегло просмотрев меню, нашел 2 кнопки удалить фильтр и скрыть фильтр. Потыкав первую увидел, что скрытые фильтром данные показываются, вторая скрывает треуголички фильтра

ну с задачей снятия всех фильтров я разобрался. Осталось доразобраться с задачей фильтрации по буферу.
Как сделать так, чтобы можно было в уже отфильтрованных данных фильтроваться дальше по другим полям? Пробовал макрорекордер, но он в принципе фигню какую-то записывает.

[sokol92]

Как сделать так, чтобы можно было в уже отфильтрованных данных фильтроваться дальше по другим полям?

Так есть подводные камни.
Напишу, как это обходить, когда будет время.

[sokol92]

В экселе можно хотя бы правой кнопкой на ячейке тыкнуть и выбрать в меню

В Excel есть очень удобная кнопка для фильтрации по значению текущей ячейки: установите, например, кнопку "Автофильтр" на панели быстрого доступа.
Я "нарисую" макрос с подобной функциональностью.

[Ezoptron]

В Excel есть очень удобная кнопка для фильтрации по значению текущей ячейки: установите, например, кнопку "Автофильтр" на панели быстрого доступа.

С экселем-то всё понятно. Вот в либре офисе я такой функции не нашёл.

[Ezoptron]

Как сделать так, чтобы можно было в уже отфильтрованных данных фильтроваться дальше по другим полям?

Так есть подводные камни.
Напишу, как это обходить, когда будет время.

Здравствуйте. Напишете про камни?