Format Text html

[Dossfm0q]

Good All below code to format individual character it works but does not work with last format so I added 1 total cell content (Len(TXT)+1), but not useful
thanks

Public Sub TXTFrmt()


Dim WB As Workbook: Set WB = ThisWorkbook
Dim WS As Worksheet: Set WS = ActiveSheet ' WB.Worksheets(1) '<<<<<<< Name it as you like
Dim Rng As Range, TblRng As Range
Dim Bold As Boolean, Italic As Boolean
    With WS
    Set TblRng = .Range("A1")
        For Each Rng In TblRng
            With Rng
 '''''''''''''''''for Example'''''''''''''''''''
    .Value = "ABCDEFGH"                        '
    With .Characters(Start:=2, Length:=1).Font '
        .FontStyle = "Bold"                    '
    End With                                   '
    With .Characters(Start:=4, Length:=2).Font '
        .FontStyle = "Bold Italic"             '
    End With                                   '
    With .Characters(Start:=7, Length:=1).Font '
        .FontStyle = "Italic"                  '
    End With                                   '
 '''''''''''''''''''''''''''''''''''''''''''''''
            
            TXT = .Text
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                For n = 1 To Len(TXT) [COLOR=#0000ff][B]+ 1[/B][/COLOR] '<<<<<
                    With .Characters(Start:=n, Length:=1)
                    T = Mid(TXT, n, 1)
                        With .Font 'Characters Font
                        B = "": EB = ""
                        I = "": EI = ""
                        If .Bold = Bold And .Italic = Italic Then
                            M = M & T
                            Bold = .Bold: Italic = .Italic ' Rest
                        ElseIf .Bold <> Bold Or .Italic <> Italic Then 'here foramt if Bold or Italic
                            If Bold = True Then B = "<B>": EB = "</B>"
                            If Italic = True Then I = "<I>": EI = "</I>"
                            M = B & I & M & EI & EB
                            RngTXT = RngTXT & M 'Format similarities
[COLOR=#0000ff]                             MsgBox M '<<[/COLOR]
                            M = "": M = T '<<<<< clear old and gather new Changes
                            Bold = .Bold: Italic = .Italic ' Rest
                        End If
                        End With 'Characters Font
                    End With
                Next n
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            End With
        Next
    End With
[COLOR=#0000ff]    MsgBox "Final :" & RngTXT '<<[/COLOR]
    
End Sub

 

[Scott Huish]

You just posted some code. What are you trying to do exactly? Can you post some sample data and the results you expect?

 

[Dossfm0q]

Thanks for respond sir
may be I got it thanks

Public Sub TXTFrmt()




Dim WB As Workbook: Set WB = ThisWorkbook
Dim WS As Worksheet: Set WS = ActiveSheet ' WB.Worksheets(1) '<<<<<<< Name it as you like
Dim Rng As Range, TblRng As Range
Dim Bold As Boolean, Italic As Boolean
Dim MYTXT As String
    With WS
    Set TblRng = .Range("A1")
        For Each Rng In TblRng
            With Rng
            
 '''''''''''''''''for Example'''''''''''''''''''
 '''''''''''''''''for Example'''''''''''''''''''
    .Value = "ABCDEFGH"                        '
    With .Characters(Start:=2, Length:=1).Font '
        .FontStyle = "Bold"                    '
    End With                                   '
    With .Characters(Start:=4, Length:=2).Font '
        .FontStyle = "Bold Italic"             '
    End With                                   '
    With .Characters(Start:=7, Length:=1).Font '
        .FontStyle = "Italic"
        .Color = RGB(255, 0, 0)
        .Size = 20
    End With                                   '
 '''''''''''''''''''''''''''''''''''''''''''''''
 '''''''''''''''''''''''''''''''''''''''''''''''
            
            TXT = .Text
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                For n = 1 To Len(TXT) + 1 '<<<<<
               ' If Trim(TXT) = "" Then Exit For
                    With .Characters(Start:=n, Length:=1)
                    T = Mid(TXT, n, 1)
                        With .Font 'Characters Font
                        FClr = "": XFClr = "": B = "": EB = "": I = "": EI = "": u = "": EU = "": strk = "": Estrk = "": Sup = "": ESup = "": Subs = "": ESubs = "": XB = "": XI = "": Xu = "": Xu2 = ""
                        
                        If n = 1 Or (Nm = .Name And Size = .Size And Clr = .Color And Bold = .Bold And Italic = .Italic And Underline = .Underline And Superscript = .Superscript And Subscript = .Subscript And n <= Len(TXT)) Then
                            M = M & T
                            Nm = .Name: Size = .Size: Clr = .Color: Bold = .Bold: Italic = .Italic: Underline = .Underline: Strikethrough = .Strikethrough: Superscript = .Superscript: Subscript = .Subscript ' Rest
                        Else 'Here foramt
                            FC = Right("000000" & Hex(Clr), 6)
                            C = Right(FC, 2) & Mid(FC, 3, 2) & Left(FC, 2)
                            FClr = IIf(Clr <> 0, "color:" & "#" & C & ";", "")
                            If Clr <> 0 Then FClr = "color:" & "#" & Right(FC, 2) & Mid(FC, 3, 2) & Left(FC, 2) & ";"
                            span = "<span dir=LTR style='font-size:" & Size & "pt;font-family:" & Nm & ",serif;" & FClr & "'>": Espan = "</span>"
                            If Bold = True Then B = "<b>": EB = "</b>": B = "<b>": EB = "</b>"
                            If Italic = True Then I = "<i>": EI = "</i>"
                            If Underline = 2 Then u = "<u>": EU = "</u>"
                            If Underline = -4119 Then u = "<u>": EI = "</u>"
                            If Strikethrough = True Then strk = "<strike>": Estrk = "</strike>"
                            If Superscript = True Then Sup = "<Sup>": ESup = "</Sup>"
                            If Subscript = True Then Subs = "<Sub>": ESubs = "</Sub>"
                            Hm = B & I & u & strk & Subs & Sup & span & M & Espan & ESup & ESubs & Estrk & EU & EI & EB
                           
                            Nm = .Name: Size = .Size: Clr = .Color: Bold = .Bold: Italic = .Italic: Underline = .Underline: Strikethrough = .Strikethrough: Superscript = .Superscript: Subscript = .Subscript ' Rest
                            RngTXT = RngTXT & Hm 'Format similarities
                            M = "": M = T '<<<<< Clear old and gather new Changes
                        End If
                        
                        End With 'Characters Font
                    End With
                    
                Next n
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                HA = .HorizontalAlignment
                HorAlign = IIf(HA = -4108, "Center", IIf((HA = 1 And IsNumeric(.Value) = False) Or HA = -4131, "Left", IIf((HA = 1 And IsNumeric(.Value) = True) Or HA = -4152, "Right", "")))


            End With
        Next
    End With
    
    '__________________________________________________________________________________________________________________________________________________________________________________________  'VVVVVVV
    MYTXT = "<p class=MsoNormal align=" & HorAlign & " dir=LTR style='margin-bottom:0in;margin-bottom:.0001pt;text-align:" & HorAlign & ";line-height:normal;direction:ltr;unicode-bidi:embed'>" & RngTXT & "</p>"
    
    '''''''''''''''''''''''''''''''''''''''''''''''
    Dim oWSHShell As Object
    Dim GetDesktop As String
    Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing
    '''''''''''''''''''''''''''''''''''''''''''''''
   'MsgBox MYTXT
Call ToText(MYTXT, GetDesktop, "Page", "htm")
'Call ToText(MYTXT, GetDesktop, "Page", "doc")


End Sub
Public Sub ToText(TXT As String, Path As String, FileName As String, Ext As String)


 Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
    Dim objShell As Object
    Dim strWordExe As String
    Set objShell = CreateObject("WScript.Shell")
    strWordExe = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\Winword.exe\")


    On Error Resume Next
    Kill Path & "\" & FileName & "." & Ext
    Set Fileout = fso.CreateTextFile(Path & "\" & FileName & "." & Ext, False, False)
    On Error GoTo 0
    
    On Error Resume Next
    Fileout.Write TXT: Fileout.Close
    On Error GoTo 0
    
    If InStr(1, Ext, "txt", vbTextCompare) > 0 Then Shell "Notepad" & " " & Path & "\" & FileName & "." & Ext, vbMaximizedFocus
    
    If InStr(1, Ext, "xml", vbTextCompare) > 0 Then Shell "Notepad" & " " & Path & "\" & FileName & "." & Ext, vbMaximizedFocus
    If InStr(1, Ext, "Doc", vbTextCompare) > 0 Then Shell strWordExe & " " & Path & "\" & FileName & "." & Ext, vbMaximizedFocus
     If InStr(1, Ext, "htm", vbTextCompare) > 0 Then Shell "explorer.exe" & " " & Path & "\" & FileName & "." & Ext, vbNormalFocus
FileName = ""


End Sub