VBA to add prefix to cell with >255 characters and retain any character formatting in the cell

[JohnWLee]

Hi,


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

I am using Excel 2010 which is what we're constrained to at work. NB: This relates to character level formatting of text within a cell rather than formatting at cell level.


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

[COLOR=black][FONT="inherit"]rCell.Characters(1, 0).Insert sString
[/FONT][/COLOR]

If the cell contains more than 255 characters then the Insert doesn't doanything i.e. the cell contents remain as they are without the prefix beinginserted.

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

[COLOR=black][FONT="inherit"]rCell.Value = sPrefix & rCell.Value

[/FONT][/COLOR]

However, that then loses all character-level formatting.


I have therefore got the following overkill code (don't laugh). The onlyformatting parameters I'm interested in are font colour/italics/bold andpotentially size. This is simply prefixing the contents of the cell with thecell row in square brackets. I've tried to make it as efficient as possible butthe 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 inorder to keep the user interested.


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


Is there a quicker/better way?

[COLOR=black][FONT="inherit"]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 insertingcharacters and resulting string is greater than 255 characters
        '/ means I had to code around it andresulting 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
       
            '/ Formatprefixed 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...
          
            '/ Establishwhat characters within the cell are bold/red/etc
            '/ (we don'tneed to worry about establishing font size for this bit)
            ReDimalFontColour(1 To lNewLenValue) As Long
            ReDimabFontBold(1 To lNewLenValue) As Boolean
            ReDimabFontItalic(1 To lNewLenValue) As Boolean[/FONT][/COLOR]

[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]            '/Populate array of formats for first n characters for prefix
            For iChr = 1To lLenPrefix
               alFontColour(iChr) = 255    'vbRed
               abFontBold(iChr) = True
               abFontItalic(iChr) = False
            Next iChr[/FONT][/COLOR]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]            '/Now populate rest of array with formats for characters which will be offset
            '/ by lengthof sPrefix
            For iChr = 1To lLenValue
               If iChr Mod 10 = 0 Then
                   Application.StatusBar = "Analysing row " & .Row _
                           & " (" & iChr & " of " & lLenValue &" characters)..."
               End If[/FONT][/COLOR]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]               With .Characters(iChr, 1)
                   alFontColour(iChr + lLenPrefix) = .Font.Color
                   abFontBold(iChr + lLenPrefix) = .Font.Bold
                   abFontItalic(iChr + lLenPrefix) = .Font.Italic
               End With
            Next iChr[/FONT][/COLOR]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]           .Value = sPrefix & .Value
           
            '/ Apply'default' formatting to the cell
            .Font.Color= 0
            .Font.Bold =False
            .Font.Italic= False
           
            '/ Nowreapply formatting to any characters that do not conform to default
            '/ (arbitaryuse of abBold array - could've been any of the related arrays)
            iStartColour= 1
            iStartBold =1
            iStartItalic= 1[/FONT][/COLOR]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]            ForiChr = 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[/FONT][/COLOR]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][COLOR=black][FONT="inherit"]               '/ If font changes colour then update all characters identified so far withprevious 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
       
            '/ ...andapply formatting to final few characters
            IfalFontColour(iStartColour) <> 0 Then
               .Characters(iStartColour, iChr - iStartColour).Font.Color =alFontColour(iStartColour)
            End If
               
            IfabFontBold(iStartBold) Then
               .Characters(iStartBold, iChr - iStartBold).Font.Bold = True
            End If
                   
            IfabFontItalic(iStartItalic) Then
               .Characters(iStartItalic, iChr - iStartItalic).Font.Italic = True
            End If
        End If
    End With
   
    Application.StatusBar = False
End Sub
[/FONT][/COLOR]

Thanks for any help


John

 

[mole999]

Please read the forum rules on cross posting and follow them. I have found at least one other, and I suspect more exist > https://www.myonlinetraininghub.com...d-retain-any-character-formatting-in-the-cell

 

[JohnWLee]

Please read the forum rules on cross posting and follow them. I have found at least one other, and I suspect more exist > https://www.myonlinetraininghub.com...d-retain-any-character-formatting-in-the-cell

Thanks for your swift response.

You have found one other - despite your suspicions there aren't any more - I posted that yesterday.

The thread you linked to was answered but wasn't what I needed to know.

Despite a lot of googling before and since then, I still haven't fund anything to help
so thought I'd post it to a wider audience such as exists on MrExcel today.

Apologies if that violates your forum rules.

Feel free to delete if you need to.

Thanks

 

[mole999]

Thanks for your swift response.

You have found one other - despite your suspicions there aren't any more - I posted that yesterday.

The thread you linked to was answered but wasn't what I needed to know.

Despite a lot of googling before and since then, I still haven't fund anything to help
so thought I'd post it to a wider audience such as exists on MrExcel today.

Apologies if that violates your forum rules.

Feel free to delete if you need to.

Thanks

As you have identified, you have already had an answer (that is reason to have the rules) so that a question asked and answered elsewhere need not be worked on again. Appreciate the answer you had, their didn't address your needs and you still want help.

 

[JohnWLee]

Thank you - and forum rules noted for future posts.