问使用VBA删除Excel注释中的空行

EN

    Sub SplitCellComment()
    '   Using the vba Split function: return each substring, and its 
    '   length, on splitting a string; _
    '    number of occurrences of a character 
    '   (ie. delimiter) within a string;

        Dim Cmt As Excel.Comment
        Dim i As Integer
        Dim LArea As Long, xCmt As Long
        Dim sText As String, sChr As String
        Dim arr As Variant, varExp As Variant, varDelim As Variant

    '   Turn the following activity off to increase program speed.
        With Application
            .StatusBar = True
            .EnableEvents = False
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With

        For Each Cmt In ActiveSheet.Comments
            sText = ""

    '       specify string expression which will be split into substrings:
            varExp = Cmt.Text

    '       specify delimiter for substrings:
            varDelim = Chr(10) '"s"

            arr = Split(varExp, varDelim)
    '       includes an array element representing a sub-string of zero- 
    '       length before the first character which is the delimiter.

            For i = LBound(arr) To UBound(arr)
    '       return each element of the array - these are the substrings into
    '       which the string expression is split into.

    '           Remove any spaces that may be present on blank rows.
                arr(i) = Trim(arr(i))

    '           If the left character of the first row = Chr(10) 
    '           then delete it.
                If Left(arr(0), 1) = Chr(10) Then Left(arr(0), 1) = ""

    '           If a row as a length of 0 then trim any spaces from the 
    '           ends. Otherwise add a Chr(10) after the text.
                If Len(arr(i)) = 0 Then
                    arr(i) = ""
                    sText = Trim(sText) & arr(i)
                Else
                    sText = Trim(sText) & Chr(10) & arr(i)
                End If

    '           Due to Chr(10) being inserted automatically at the 
    '           beginning of the text, this will remove the first character.
                If i = 0 Then
                    If Len(sText) <> Len(arr(0)) Then
                        sText = Mid(sText, 2, Len(sText))
                    End If
                End If

    '           In some cases the next If...Then is required to remove 
    '           non-printable characters.
                On Error Resume Next
                If Asc(Left(sText, 1)) < 32 Then sText = Mid(sText, 2, Len(sText))
                On Error GoTo 0
            Next i
            Cmt.Text sText

    '       Format comment shape, size and font.
            With Cmt
    '           Beveled button
                .Shape.AutoShapeType = msoShapeActionButtonCustom    
                .Shape.TextFrame.Characters.Font.Name = "Tahoma"
                .Shape.TextFrame.Characters.Font.Size = 10
                .Shape.TextFrame.Characters.Font.ColorIndex = 2
                .Shape.Line.ForeColor.RGB = RGB(0, 0, 0)
                .Shape.Line.BackColor.RGB = RGB(255, 255, 255)
                .Shape.Fill.Visible = msoTrue
                .Shape.Fill.ForeColor.RGB = RGB(58, 82, 184)
                .Shape.Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.23
            End With
        Next Cmt

    '   Return the following activity on for future use.
        With Application
            .StatusBar = False
            .EnableEvents = True
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With
    End Sub