.Cells(i, 3).Value = Replace(com.Text, com.Author & ":" & Chr(10), "")

.Cells(i, 3).Value = Replace(com.Text, com.Author & ":", "")

Sub qq()
x = Val(Selection.Text)
a = Format(x, "#")
End Sub

Sub Мяу()
    Dim lk As Object, calc&
    Application.ScreenUpdating = False
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    For Each lk In Range("Таблица1").ListObject.ListColumns
        If lk.DataBodyRange.Text = Empty Then
            lk.Delete
        End If
    Next
    Application.Calculation = calc
    Application.ScreenUpdating = True
End Sub

NewBook = "" 'Создаем новую книгу

Sub ИД()
    Application.ScreenUpdating = False    'Отключаем обновление экрана
    Application.EnableEvents = False    'Отключаем отслеживание событий
    Application.DisplayAlerts = False    'Отключаем вывод сообщений во время макроса
    calc = Application.Calculation
    Dim Papka_name1 As String, Name_file1 As String, ar
    Papka_name1 = "D:\abcd"    'ThisWorkbook.Path & "\" & Sheets("Х").Cells(2, 3).Value & "- ИД.НО"
    If Dir(Papka_name1, 16) = "" Then
        MkDir Papka_name1
    End If
    Sheets(Array("Х", "Т1", "Р", "АТП", "С")).Copy    ' Копируем листы
    ar = Array("Т1", "Р", "АТП", "С")
    For i = 0 To UBound(ar)
        Sheets(ar(i)).AutoFilter.Range.AutoFilter Field:=1, Criteria1:="Да"
    Next
    Name_file1 = Papka_name1 & "\" & Sheets("Х").Cells(2, 3).Value & "- ИД.НО " & ".xlsx"    'Имя файла ИД редакируемый
    ActiveWorkbook.SaveAs Filename:=Name_file1, FileFormat:=51
    ActiveWorkbook.Close False
    Exit Sub
    Application.ScreenUpdating = True    'Отключаем обновление экрана
    Application.EnableEvents = True    'Отключаем отслеживание событий
    Application.DisplayAlerts = True    'Отключаем вывод сообщений во время макроса
    Application.Calculation = calc    'Включаем автопересчет формул
End Sub

iText = Array("  ЕдОборуд", "Название технического объекта", "ВидОбъекта", "PIPE A")    'список слов на удаление

For kk = UBound(ar, 2) To 1 Step -1

    For i = 0 To UBound(iText)
        Set iRange = Columns("A:K").Find(What:=iText(i), LookIn:=xlFormulas, Lookat:=xlWhole)
        If Not iRange Is Nothing Then
            Do
                iRange.EntireRow.Delete
                Set iRange = Columns("A:K").Find(What:=iText(i), _
                                                 LookIn:=xlFormulas, Lookat:=xlWhole)
            Loop Until iRange Is Nothing
        End If
    Next i

    Dim ar, lr&
    lr = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    ar = Range("A1:K" & lr).Value
    For k = UBound(ar) To 1 Step -1
        For kk = 1 To UBound(ar, 2)
            For i = 0 To UBound(iText)
                If ar(k, kk) = iText(i) Then
                    Rows(k).Delete
                    GoTo metka
                End If
            Next
        Next
metka:
    Next

Sub qqq()
    Dim cl As Range
    On Error Resume Next
    For Each cl In Intersect(Sheets(1).Columns(2), Sheets(1).UsedRange).Cells
        If Len(cl) Then
            cl.Hyperlinks(1).Follow
            qq
        End If
    Next
End Sub