Export text with VBA

[RogerSt]

Hello all

First of all i work with Excel 2010.
I have an excel sheet witch has some textblocks.
I want do export this textblocks via vba.

The problem is not the export.
The problem ist the formating.
in excel a cell looks like this

-------------------------------------------------
Here is some headertext


here follow some normal text with Bold and Unerline word.


Some text with address and odther infomation and bla bla bla bla bla bla

bla bla bla bla bla bla some wath bla bla
-------------------------------------------------

(Bold parts are not shown in this text)

in the export i have to write the following:
-------------------------------------------------
%BOLD_ON%Here is some headertext%BOLD_OFF%


here follow some normal text with Bold and Unerline word.


Some text with %BOLD_ON%address%BOLD_OFF% and odther %UNDERLINE_ON%infomation%UNDERLINE_OFF% and bla bla bla bla bla bla

bla bla bla bla bla bla %BOLD_ON%%UNDERLINE_ON%some wath%BOLD_OFF%%UNDERLINE_OFF% bla bla
-------------------------------------------------

Right now i do this with this code

Function check_bold_and_underline(inpcell As Range) As Variant
    ' Test ob ganzes Feld BOLD (fnt=TRUE)
    ' ganzes Feld nicht Bold (fnt=FALSE)
    ' oder Teilweise Bold (fnt=NULL)
     fnt = inpcell.Font.Bold
    ' Test ob ganzes Feld Underline (fntu=xlUnderlineStyleSingle)
    ' ganzes Feld nicht Underline (fntu=xlUnderlineStyleNone)
    ' oder Teilweise Underine (fntu=NULL)
     fntu = inpcell.Font.Underline
     temptext = ""
     last_font = False
     last_fontu = xlUnderlineStyleNone
     If fnt = True Then
         temptext = "#BOLD#"
         last_font = fnt
     End If
     If fntu = xlUnderlineStyleSingle Then
         temptext = "#UNDERLINE (ON)#" & temptext
         last_fontu = fntu
     End If
     
     If IsNull(fntu) Or IsNull(fnt) Then
         For p = 1 To Len(inpcell.Value)
             If IsNull(fnt) Then
                 If inpcell.Characters(p, 1).Font.Bold <> last_font Then
                     If last_font = False Then
                         temptext = temptext & "%BOLD_ON%"
                         last_font = True
                     Else
                         temptext = temptext & "%BOLD_OFF%"
                         last_font = False
                     End If
                 End If
             End If
             If IsNull(fntu) Then
                 If inpcell.Characters(p, 1).Font.Underline <> last_fontu Then
                     If last_fontu = xlUnderlineStyleNone Then
                         temptext = temptext & "%UNDERLINE_ON%"
                         last_fontu = xlUnderlineStyleSingle
                     Else
                         temptext = temptext & "%UNDERLINE_OFF%"
                         last_fontu = xlUnderlineStyleNone
                     End If
                 End If
             End If
             temptext = temptext & Mid(inpcell, p, 1)
         Next p
     Else
         temptext = temptext & inpcell.Value
     End If
     check_bold_and_underline = temptext
End Function

My problem ist the time witch is used.
If the cells has 1000 characters,the routine will take 35 seconds.
With Excel 2003 the same Script takes about 10 seconds.

Any idea? how i can speed up the script or is there an other function in Excel 2010?

Best regards
Roger