Sub TrimLeadingAndTrailingSpaces()

    ' Updated 2021-06-03
    '
    ' Deletes leading and trailing spaces from non-formula Excel cells in the current selection without affecting character-level formatting
    ' Deletes all spaces from cells that contain only spaces
    ' Deletes non-breaking as well as regular spaces
    ' Cells that contained spaces are shaded in green
    ' Cells with more than 255 characters of text are too long to trim programatically and are shaded in yellow
    '
    ' Based on the macro "trimspace" at https://www.exceltip.com/general-topics-in-vba/remove-trailing-space-through-vba.html
    ' With assistance from Tim Williams: https://stackoverflow.com/questions/67828540/trimming-blank-spaces-in-excel-without-losing-formatting/67829527#67829527
    '
    ' Adapted/written by Michael Schuler (https://bergerplusschuler.com)


    Dim rCell As Range
    Dim rSelection As Range
    Dim iSpaces As Long
    Dim iCells As Long
    Dim bFlag As Boolean
    Const sDialogTitle As String = "Trim Leading and Trailing Spaces"
    
    On Error GoTo Err_Msg
    
    If Selection.Cells.Count = 1 Then
        Set rSelection = Selection
        Else
          Set rSelection = Selection.SpecialCells(2, 2)
    End If
    If Not rSelection Is Nothing Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For Each rCell In rSelection
            If Len(rCell.Value) < 256 Then
                Do While Asc(Right(rCell.Value, 1)) = 32 Or Asc(Right(rCell.Value, 1)) = 160
                    rCell.Characters(Len(rCell.Value), 1).Delete
                    iSpaces = iSpaces + 1
                    bFlag = True
                    If Len(rCell.Value) = 0 Then Exit Do
                Loop
                If Len(rCell.Value) > 0 Then
                    Do While Asc(Left(rCell.Value, 1)) = 32 Or Asc(Left(rCell.Value, 1)) = 160
                        rCell.Characters(1, 1).Delete
                        iSpaces = iSpaces + 1
                        bFlag = True
                        If Len(rCell.Value) = 0 Then Exit Do
                    Loop
                End If
                If bFlag = True Then
                    'rCell.BorderAround Weight:=xlThick, ColorIndex:=10
                    rCell.Interior.Color = RGB(190, 255, 190)
                    iCells = iCells + 1
                    bFlag = False
                End If
            ElseIf Asc(Right(rCell.Value, 1)) = 32 Or Asc(Right(rCell.Value, 1)) = 160 Or Asc(Left(rCell.Value, 1)) = 32 Or Asc(Left(rCell.Value, 1)) = 160 Then
                 MsgBox "One or more cells containing trailing or leading spaces were too long to automatically edit." & Chr(13) & Chr(13) & "These have been shaded in yellow. Please adjust them manually.", vbExclamation, sDialogTitle
                 'rCell.BorderAround Weight:=xlThick, ColorIndex:=3
                 rCell.Interior.Color = RGB(255, 255, 150)
            End If
        Next rCell
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        MsgBox iSpaces & " spaces in " & iCells & " cells deleted." & Chr(13) & Chr(13) & "Adjusted cells have been shaded in green.", vbInformation, sDialogTitle
    End If

Macroend:
    Exit Sub
    
Err_Msg:
    MsgBox "The macro has encountered an error." & vbCrLf & Err.Number & ": " & Err.Description, vbCritical, sDialogTitle

End Sub