Sub Макрос1()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        Dim arr(), s As String, r As Range, i As Integer, m As Long
        Set r = Intersect(ActiveSheet.UsedRange, Selection)
        m = 1
        For Each n In r
            For i = 1 To Len(n)
                If r.Cells(m).Characters(Start:=i, Length:=1).Font.Bold = True Or Mid(r.Cells(m), i, 1) = " " Then s = s & Mid(r.Cells(m), i, 1)
            Next i
            r.Cells(m) = WorksheetFunction.Trim(s): s = "": m = m + 1
        Next n
        r.Font.Bold = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub