СОРТИРОВКА строк массово по ключевому слову с объединением по схожести

[admin]

• При запуске появляется два окна запроса:
  • Первое — ввод буквы столбца, в котором нужно искать слово (например, A, B, C).
  • Второе — ввод ключевого слова, которое нужно найти (например, трость).

• Макрос:
  • ищет слово в указанном столбце,
  • выделяет строки, в которых найдено совпадение,
  • группирует такие строки вверху таблицы,
  • подсвечивает найденные строки зелёным.

1. Открыть редактор макросов — сочетанием Alt + F11
2. Выделить ваш проект левой кнопкой мыши (VBAProject (Ваш проект.xIsx), нажать на нем правой и выбрать: Вставить - Модуль (Insert > Module)
3. В пустом окне нового модуля пишем код:

Sub ClusterRowsBySelectedColumnAndKeyword()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim keyword As String
    Dim colLetter As String
    Dim colNumber As Long
    Dim tempCol As String: tempCol = "Z" ' Temporary column for match flag

    Set ws = ActiveSheet

    ' Ask user for column letter
    colLetter = InputBox("Enter the column letter to search in (e.g., A, B, C):", "Select Column")
    If Trim(colLetter) = "" Then
        MsgBox "Operation cancelled (no column selected).", vbExclamation
        Exit Sub
    End If
    
    ' Convert column letter to number (e.g., A → 1, B → 2)
    On Error Resume Next
    colNumber = Range(colLetter & "1").Column
    On Error GoTo 0
    If colNumber = 0 Then
        MsgBox "Invalid column letter: " & colLetter, vbCritical
        Exit Sub
    End If

    ' Ask user for keyword
    keyword = InputBox("Enter the keyword to group rows by (e.g., трость):", "Enter Keyword")
    If Trim(keyword) = "" Then
        MsgBox "Operation cancelled (no keyword provided).", vbExclamation
        Exit Sub
    End If

    ' Determine the last row in the selected column
    lastRow = ws.Cells(ws.Rows.Count, colNumber).End(xlUp).Row

    ' Clear helper column and previous formatting
    ws.Range(tempCol & "1:" & tempCol & lastRow).ClearContents
    ws.Range("A2:Z" & lastRow).Interior.ColorIndex = xlNone
    ws.Cells(1, tempCol).Value = "Match"

    ' Search for keyword in selected column and mark matches
    For i = 2 To lastRow
        If InStr(1, LCase(ws.Cells(i, colNumber).Value), LCase(keyword)) > 0 Then
            ws.Cells(i, tempCol).Value = 1 ' Match found
            ws.Rows(i).Interior.Color = RGB(198, 239, 206) ' Light green
        Else
            ws.Cells(i, tempCol).Value = 0 ' No match
        End If
    Next i

    ' Sort the full table by the match flag in column Z
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range(tempCol & "2:" & tempCol & lastRow), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange ws.Range("A1").Resize(lastRow, ws.UsedRange.Columns.Count)
        .Header = xlYes
        .Apply
    End With

    ' Show result
    MsgBox "Rows grouped and highlighted by keyword """ & keyword & """ in column " & UCase(colLetter), vbInformation

    ' Optional: remove helper column
    ' ws.Columns(tempCol).ClearContents
End Sub

4. Открыть выполнение макросов — сочетанием Alt + F8
5. Выбираем макрос по названию в окне
6. Жмем "Выполнить" и смотрим результат