VBA to add prefix to cell with >255 characters and retain any character formatting in the cell|VBA & Macros|Excel Forum|My Online Training Hub

Hi,

I am struggling to get a satisfactory method of doing this and from googling it, it seems to be due to a suspected bug in Excel but I haven't been able to find anything that provides any help with my specific requirement.

So, if the cell and prefix to be added to the cell's contents is less than 255 characters then the following simple code does the trick:

rCell.Characters(1, 0).Insert sString

If the cell contains more than 255 characters then the Insert doesn't do anything i.e. the cell contents remain as they are without the prefix being inserted.

To get the prefix in place I have used the following:

rCell.Value = sPrefix & rCell.Value

However, that then loses all character-level formatting.

I have therefore got the following overkill code (don't laugh). The only formatting parameters I'm interested in are font colour/italics/bold and potentially size. This is simply prefixing the contents of the cell with the cell row in square brackets. I've tried to make it as efficient as possible but the trawling through the characters to get the formats is an absolute killer, so much so I've had to update the statusbar to show something's happening in order to keep the user interested.

I have even tried copying the cell's contents to Word, amending the text/formatting there and copying it back, but that was singularly unsuccessful too.

Is there a quicker/better way?

Private Sub AnnotateCell(ByRef MyCell As Range)
    Dim iChr As Integer
    Dim alFontColour() As Long
    Dim abFontBold() As Boolean
    Dim abFontItalic() As Boolean
   
    Dim iStartColour As Integer
    Dim iStartBold As Integer
    Dim iStartItalic As Integer
   
    Dim sPrefix As String
    Dim lLenValue As Long
    Dim lLenPrefix As Long
    Dim lNewLenValue As Long
   
    With MyCell
        sPrefix = "[" & .Row & "] "
       
        lLenValue = Len(.Value)
        lLenPrefix = Len(sPrefix)
        lNewLenValue = lLenPrefix + lLenValue
       
        '/ Excel bug when inserting characters and resulting string is greater than 255 characters
        '/ means I had to code around it and resulting execution is quite slow. You're welcome to
        '/ find and code a better method...
        If lNewLenValue <= 255 Then
            .Range("A1").Characters(1, 0).Insert sPrefix
       
            '/ Format prefixed annotation...
            With .Characters(1, lLenPrefix).Font
                .Color = vbRed
                .Bold = True
                .Italic = False
                .Size = 9
            End With
       
        Else '/ we're dealing with a string > 255 chars and it's slow...
          
            '/ Establish what characters within the cell are bold/red/etc
            '/ (we don't need to worry about establishing font size for this bit)
            ReDim alFontColour(1 To lNewLenValue) As Long
            ReDim abFontBold(1 To lNewLenValue) As Boolean
            ReDim abFontItalic(1 To lNewLenValue) As Boolean

            '/ Populate array of formats for first n characters for prefix
            For iChr = 1 To lLenPrefix
                alFontColour(iChr) = 255    'vbRed
                abFontBold(iChr) = True
                abFontItalic(iChr) = False
            Next iChr

            '/ Now populate rest of array with formats for characters which will be offset
            '/ by length of sPrefix
            For iChr = 1 To lLenValue
                If iChr Mod 10 = 0 Then
                    Application.StatusBar = "Analysing row " & .Row _
                            & " (" & iChr & " of " & lLenValue & " characters)..."
                End If

                With .Characters(iChr, 1)
                    alFontColour(iChr + lLenPrefix) = .Font.Color
                    abFontBold(iChr + lLenPrefix) = .Font.Bold
                    abFontItalic(iChr + lLenPrefix) = .Font.Italic
                End With
            Next iChr

            .Value = sPrefix & .Value
           
            '/ Apply 'default' formatting to the cell
            .Font.Color = 0
            .Font.Bold = False
            .Font.Italic = False
           
            '/ Now reapply formatting to any characters that do not conform to default
            '/ (arbitary use of abBold array - could've been any of the related arrays)
            iStartColour = 1
            iStartBold = 1
            iStartItalic = 1

            For iChr = LBound(abFontBold) + 1 To UBound(abFontBold)
               
                '/ Tell user something's happening
                If iChr Mod 10 = 0 Then
                    Application.StatusBar = "Reformatting row " & .Row _
                            & " (" & iChr & " of " & lNewLenValue & " characters)..."
                End If

                '/ If font changes colour then update all characters identified so far with previous colour...
                If alFontColour(iChr) <> alFontColour(iChr - 1) Then
                    If alFontColour(iStartColour) <> 0 Then
                        .Characters(iStartColour, iChr - iStartColour).Font.Color = alFontColour(iStartColour)
                    End If
                   
                    iStartColour = iChr '/ repopulated for next change...
                End If
               
                '/ ...and ditto with bold property...
                If abFontBold(iChr) <> abFontBold(iChr - 1) Then
                    If abFontBold(iStartBold) Then
                        .Characters(iStartBold, iChr - iStartBold).Font.Bold = True
                    End If
                   
                    iStartBold = iChr
                End If
                   
                '/ ...and finally italics
                If abFontItalic(iChr) <> abFontItalic(iChr - 1) Then
                    If abFontItalic(iStartItalic) Then
                        .Characters(iStartItalic, iChr - iStartItalic).Font.Italic = True
                    End If
                   
                    iStartItalic = iChr
                End If
                   
                'Font size is retained so no processing required for that
            Next iChr
       
            '/ ...and apply formatting to final few characters
            If alFontColour(iStartColour) <> 0 Then
                .Characters(iStartColour, iChr - iStartColour).Font.Color = alFontColour(iStartColour)
            End If
               
            If abFontBold(iStartBold) Then
                .Characters(iStartBold, iChr - iStartBold).Font.Bold = True
            End If
                   
            If abFontItalic(iStartItalic) Then
                .Characters(iStartItalic, iChr - iStartItalic).Font.Italic = True
            End If
        End If
    End With
   
    Application.StatusBar = False
End Sub

Thanks for any help

John