Formatting HTML data in excel

Sub main()
    Dim Ie As Object
    On Error Resume Next

'    Worksheets.Add(After:=Worksheets(1)).Name = "Sheet1"
    Workbooks("Defects.xls").Sheets("Query1").Select
    Columns("A:AB").Select
    Selection.NumberFormat = "General"
    Columns("J:N").Select
    Selection.NumberFormat = "m/d/yyyy"
    Set Ie = CreateObject("InternetExplorer.Application")
    For i = 2 To Sheets("Query1").UsedRange.Rows.Count
        With Ie
            .Visible = False
            .Navigate "about:blank"
            .document.body.InnerHTML = Sheets("Query1").Cells(i, 6).Value
            .document.body.createtextrange.execCommand "Copy"
            ActiveSheet.Paste Destination:=Sheets("Query1").Range("AD1")
        End With
        LastRow = Sheets("Query1").Range("AD65536").End(xlUp).Row
        Call ConcatenateRichText(Sheets("Query1").Range("F" & i), Sheets("Query1").Range("AD1:AD" & LastRow))
        Trim (Sheets("Query1").Range("F" & i))
    Workbooks("Defects.xls").Sheets("Query1").Select
    Columns("AD:AD").Select
    Selection.ClearContents
    Next
    Ie.Quit
    MsgBox "Finished"
End Sub
Sub ConcatenateRichText(Target As Range, Source As Range)
    Dim Cell As Range
    Dim i As Long
    Dim c As Long
    i = 1
    With Target
        .Clear
        For Each Cell In Source
            .Value = .Value & vbLf & Cell.Value
        Next Cell
        .Value = Trim(.Value)
    End With
    For Each Cell In Source
        For c = 1 To Len(Cell.Value)
            With Target.Characters(i, 1).Font
                .Name = Cell.Characters(c, 1).Font.Name
                .FontStyle = Cell.Characters(c, 1).Font.FontStyle
                .Size = Cell.Characters(c, 1).Font.Size
                .Strikethrough = Cell.Characters(c, 1).Font.Strikethrough
                .Superscript = Cell.Characters(c, 1).Font.Superscript
                .Subscript = Cell.Characters(c, 1).Font.Subscript
                .OutlineFont = Cell.Characters(c, 1).Font.OutlineFont
                .Shadow = Cell.Characters(c, 1).Font.Shadow
                .Underline = Cell.Characters(c, 1).Font.Underline
                .ColorIndex = Cell.Characters(c, 1).Font.ColorIndex
            End With
            i = i + 1
        Next c
        i = i + 1
    Next Cell
End Sub