j = InStr(1, s, "душ", 1)
        If j > 0 Then a(i, 1) = "душ"

  Const MinLength = 4         ' Мин. длина слова в символах
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"  ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]{" & MinLength & ",})[( ]"
    
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
      
  ' Найти первое русское слова по шаблону
  With CreateObject("VBScript.RegExp")
    .Global = True
    .IgnoreCase = True
    For i = 1 To UBound(a)
      s = Trim(a(i, 1))
      If Len(s) = 0 Then
        a(i, 1) = Empty
      Else
        a(i, 1) = "(нет)"
        ' --> Исключения из правил
        If InStr(1, s, "душ", 1) > 0 Then a(i, 1) = "душ"
        'If InStr(1, s, "хром", 1) > 0 Then s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец исключений
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If InStr(ExcludeList, Right(s, 2)) = 0 Then
            a(i, 1) = s
            Set Obj = Nothing
            Exit For
          End If
        Next
      End If
    Next
  End With
    
  ' Поместить результат в столбец [h]
  Rng.EntireRow.Columns("h").Value = a()

    ' сортировка двумерного массива по столбцу N
    N = 5
    Dim Check As Boolean
    ReDim tmpArr(FinalColumn) As Variant
    Do Until Check
        Check = True
        For i = 1 To FinalRow - 1
            If Val(R_data(i, N)) < Val(R_data(i + 1, N)) Then
                For j = 1 To FinalColumn
                    tmpArr(j) = R_data(i, j)
                     R_data(i, j) = R_data(i + 1, j)
                     R_data(i + 1, j) = tmpArr(j)
                    Check = False
                Next
            End If
        Next
    Loop

Sub Main()
 
  Const MinLength = 4  ' Мин. длина слова в символах
   
  Dim i As Long, a() As Variant, Rng As Range, s As String
 
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("d2", .Cells(.Rows.Count, "d").End(xlUp))
  End With
  a() = Rng.Value
   
  ' Найти первоое русское слова по шаблону
  With CreateObject("VBScript.RegExp")
    .Global = False
    .IgnoreCase = True
    .Pattern = " ([А-ЯЁ\-]{" & MinLength & ",})\,? "
    For i = 1 To UBound(a)
      s = Trim(a(i, 1))
      If Len(s) = 0 Then
        a(i, 1) = Empty
      Else
        With .Execute(" " & s & " ")
          If .Count > 0 Then
            a(i, 1) = LCase(.Item(0).SubMatches(0))
          Else
            a(i, 1) = "(нет)"
          End If
        End With
      End If
    Next
  End With
   
  ' Поместить результат в столбец [I]
  Rng.EntireRow.Columns(6).Value = a()
   
End Sub

For i = 1 To UBound(a) 
 if Sheets(1).Cells(i, 2).Value = "" then
     Sheets(1).Cells(i, q).Value = ""
 end if    
 Sheets(1).Cells(i, q).Value = LCase(Sheets(1).Cells(i, q).Value)
Next i    

Dim i As Long, a() As Variant, Rng As Range
  
  Static RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = False
    RegEx.IgnoreCase = True
    RegEx.Pattern = " ([А-ЯЁ\-]{" & "4" & ",})\.? "
  End If                                                              
  
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))    
  End With                                      
  a() = Rng.Value
  For i = 1 To UBound(a)
      With RegEx.Execute(" " & CStr(a(i, 1)) & " ")
        If .Count > 0 Then a(i, 1) = .Item(0).SubMatches(0)
      End With
  Next
  Rng.Columns(8).Value = a()  

ActiveWorkbook.Names.Add Name:="asd", RefersToR1C1:= _
        "=TRIM(MID(SUBSTITUTE(TRIM(RC[-7]),"" "",REPT("" "",99)),99*(" & Chr(10) & "MATCH(,MMULT(--ISNUMBER(FIND(CHAR(COLUMN(R1C1:R1C191)),SUBSTITUTE(LOWER(TRIM(MID(SUBSTITUTE(TRIM(RC[-7]),"" "",REPT("" "",99)),99*(ROW(R1:R99)-1)+1,99))),""ё"",""е""))),TRANSPOSE(COLUMN(R1C1:R1C191)^0)),)" & Chr(10) & "-1)+1,99))"
   

     ActiveSheet.Cells(i, q).Select
       ActiveCell.FormulaR1C1 = "=asd"  

Спасибо - заработало!