' сортировка двумерного массива по столбцу 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