let
  src = Table.Buffer ( Excel.CurrentWorkbook(){[ Name = "data" ]}[Content] ),
  clmnNames = List.Buffer ( Table.ColumnNames ( src ) ),
  filterValues = List.Buffer ( Excel.CurrentWorkbook(){[ Name = "filterValues" ]}[Content][Значение] ),
  addComb = Table.AddColumn (
    src,
    "comb",
    each List.Accumulate (
      List.Sort ( List.Difference ( List.RemoveNulls ( List.Distinct ( Record.ToList ( _ ) ) ), filterValues ) ),
      { {} },
      ( s, c ) => s & List.Transform ( s, ( x ) => x & { c } )
    )
  ),
  expand = Table.ExpandListColumn ( addComb[[comb]], "comb" ),
  addCount = Table.AddColumn ( expand, "КолЭл", each List.Count ( [comb] ), Int64.Type ),
  parameters = Record.FromTable (
    Table.FromColumns ( Table.ToColumns ( Excel.CurrentWorkbook(){[ Name = "parameters" ]}[Content] ), type table [ Name = text, Value = number ] )
  ),
  filterElements = Table.SelectRows (
    addCount,
    each [КолЭл] = Record.FieldOrDefault ( parameters, "Количество элементов в сочетании", null )
  ),
  toRec = Table.TransformColumns ( filterElements, { "comb", ( x ) => Record.FromList ( x, List.FirstN ( clmnNames, List.Count ( x ) ) ) } ),
  group = Table.Group ( toRec, { "comb", "КолЭл" }, { { "Повт", each Table.RowCount ( _ ), Int64.Type } } ),
  filterRepeats = Table.SelectRows ( group, each [Повт] >= Record.FieldOrDefault ( parameters, "Минимальное число повторений", null ) ),
  sort = Table.Sort ( filterRepeats, { { "КолЭл", Order.Descending }, { "Повт", Order.Descending } } ),
  expandRecs = Table.ExpandRecordColumn ( sort, "comb", List.FirstN ( clmnNames, sort[КолЭл]{0} ) )
in
  expandRecs

Sub DeleteCellByVal()
    Dim r As Range, s As String, sDefaultText As String, sArr As Variant, i As Byte
    sDefaultText = GetSetting("DeleteCellByValue", "Folder1", "DefaultString")
    s = InputBox("Введите искомый текст", "Удаление текста", sDefaultText)
    s = Application.WorksheetFunction.Trim(s)
    If s = "" Then Exit Sub
    SaveSetting "DeleteCellByValue", "Folder1", "DefaultString", s
    If TypeName(Selection) = "Range" Then
        Set r = Selection
        If r.Cells.Count = 1 Then
            MsgBox "Выделенна только одна ячейка!", vbQuestion, "Вы серьёзно?"
            Exit Sub
        End If
    Else
        Exit Sub
    End If
    Application.ScreenUpdating = False
    If InStr(1, s, " ") > 0 Then
        sArr = Split(s, " ")
        For i = LBound(sArr) To UBound(sArr)
            r.Replace sArr(i), "", 1
        Next i
    Else
        r.Replace s, "", 1
    End If
        r.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub