let
    Source = Excel.CurrentWorkbook(){[Name="Таблица4"]}[Content],
    Result = Table.TransformColumns(Source, {"Столбец3", each Number.ToText(_, " 000-000-000000"), Text.Type})
in
    Result

Set .SendUsingAccount = objOutlookApp.Session.Accounts.Item("testmail@mail.ru")

Sub Test()
  ' Reference: Tools - References - Windows Script Host Object Model
  ' File: C:\Windows\System32\wshom.ocx
  Dim intReturn
  Dim WshShell As IWshRuntimeLibrary.WshShell
  Set WshShell = New IWshRuntimeLibrary.WshShell
  Range("C20").Value = 255
  intReturn = WshShell.Run("C:\ABC\GetData.exe X", 0, True)
  Range("C20").Value = intReturn
End Sub

Sub Test()
  ' Reference: Tools - References - Windows Script Host Object Model
  ' File: C:\Windows\System32\wshom.ocx
  Dim WshShell As IWshRuntimeLibrary.WshShell
  Set WshShell = New IWshRuntimeLibrary.WshShell
  WshShell.Popup "Hi!"
End Sub

Sub Main()
   
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "гостиная,душевая" ' Список (белый) допустимых слов
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([abcekmnhoptuyА-ЯЁ\-]*)[( ]" ' "abcekmnhoptuy" - нерусские буквы, которые могут выглядеть как русские
   
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
      
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
     
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    .CompareMode = 1
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
     
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Dic.Exists(s) Then
            a(i, 1) = s
            Exit For
          End If
          If Len(s) >= MinLength Then
            If s Like "*[а-яё]*" Then
              If InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
                a(i, 1) = s
                Exit For
              End If
            End If
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
   
  ' Поместить результат в столбец [q]
  Rng.EntireRow.Columns("q").Value = a()
    
End Sub

Sub Main()
  
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "гостиная,душевая" ' Список (белый) допустимых русских слов
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]*)[( ]"
  
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
     
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
    
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
    
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Dic.Exists(s) Then
            a(i, 1) = s
            Exit For
          End If
          If InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
            a(i, 1) = s
            Exit For
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
  
  ' Поместить результат в столбец [q]
  Rng.EntireRow.Columns("q").Value = a()
   
End Sub

Sub Main()
 
  Const MinLength = 4                 ' Мин. длина слова в символах
  Const GoodList = "душ,муж,куш"      ' Список (белый) допустимых русских словё длиной <  MinLength
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"   ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]*)[( ]"
 
  Dim i As Long, a() As Variant, Obj As Object, Rng As Range, s As String
  Dim Dic As Object, w As Variant
    
  ' Задать диапазон входных данных
  With ThisWorkbook.Sheets(1)
    Set Rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
  End With
  a() = Rng.Value
   
  ' Создать словарь слов белого списка
  Set Dic = CreateObject("Scripting.Dictionary")
  With Dic
    For Each w In Split(GoodList, ",")
      .Item(Trim(w)) = Empty
    Next
  End With
   
  ' Найти первое русское слова по шаблону
  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 s = Replace(s, "хром", "", Compare:=1)
        ' <-- Конец удаления
        .Pattern = Pattern1
        s = .Replace(s, " _")
        .Pattern = Pattern2
        For Each Obj In .Execute("_" & s & " ")
          s = LCase(Obj.SubMatches(0))
          If Len(s) < MinLength Then
            If Dic.Exists(s) Then
              a(i, 1) = s
              Exit For
            End If
          ElseIf InStr(1, ExcludeList, Right(s, 2), vbTextCompare) = 0 Then
            a(i, 1) = s
            Exit For
          End If
        Next
      End If
    Next
    Set Obj = Nothing
    Set Dic = Nothing
  End With
 
  ' Поместить результат в столбец [e]
  Rng.EntireRow.Columns("e").Value = a()
  
End Sub

Sub Main()

  Const MinLength = 4          ' Мин. длина слова в символах
  Const ExcludeList = "ая,ый,ое,ий,ой,ые,яя,ся,ее"  ' Окончания игнорируемых слов
  Const Pattern1 = "[\u00A0,\.\/ ]"  ' 1-й символ это CHR(160), последний - пробел
  Const Pattern2 = "\b_([А-ЯЁ\-]{" & MinLength & ",})[( ]"

  Dim i As Long, j 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 New RegExp ' 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) = "(нет)"

        ' --> Исключения из правил
        j = InStr(1, s, "душ", 1)
        If j > 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
            If j Then
              If Obj.FirstIndex < j Then a(i, 1) = s
            Else
              a(i, 1) = s
            End If
            Exit For
          End If
        Next
      End If
    Next
    Set Obj = Nothing
  End With

  ' Поместить результат в столбец [h]
  Rng.EntireRow.Columns("h").Value = a()
End Sub

Sub Main()
 
  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) = 1 Then
          a(i, 1) = "душ"
        Else
          '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
      End If
    Next
  End With
     
  ' Поместить результат в столбец [h]
  Rng.EntireRow.Columns("h").Value = a()
End Sub