Function MergeIf(TextRange As Range, SearchRange As Range, Condition As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
     
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If SearchRange.Count <> TextRange.Count Then
        MergeIf = CVErr(xlErrRef)
        Exit Function
    End If
     
    'проходим по все ячейкам, проверяем условие и собираем текст в переменную OutText
    For i = 1 To SearchRange.Cells.Count
        If SearchRange.Cells(i) Like Condition Then OutText = OutText & TextRange.Cells(i) & Delimeter
    Next i
     
    'выводим результаты без последнего разделителя
    MergeIf = Left(OutText, Len(OutText) - Len(Delimeter))
End Function

Function VLOOKUP3(Table As Range, SearchColumnNum As Integer, _
                  SearchValue As Variant, ResultColumnNum As Integer)
'улучшенная функция ВПР вводится как формула массива
'ищет указанной значение в указанном столбце и выводит все соответствия из указанного столбца
    Dim i&, j&
    Dim a
    ReDim Out(1 To Table.Rows.Count, 1 To 1) As Variant

    a = Table.Value
    For i = 1 To Table.Rows.Count
        If a(i, SearchColumnNum) = SearchValue Then
            j = j + 1
            Out(j, 1) = a(i, ResultColumnNum)
        End If
    Next i
    VLOOKUP3 = Out
End Function

Sub ToCentre()
  Dim Lr&, R&, R1&, rg As Range
  Lr = ActiveCell.End(xlDown).Row:   Set rg = ActiveCell.Offset(0, -1)
  Do While R < Lr
    If Not IsEmpty(rg.Offset(1, 0)) Then R = rg.Row + 1 Else R = rg.End(xlDown).Row - 1: If R > Lr Then R = Lr
    If R - rg.Row > 3 Then
      R1 = Int((rg.Row + R) / 2): Cells(R1, 1) = rg:  Cells(R1, 9) = rg.Offset(0, 
      rg = Empty:  rg.Offset(0,  = Empty
    End If
    Set rg = Cells(R, 1)
  Loop
End Sub