Colouring Strikethrough/Underline text within a cell via Loop

Hi Everyone,

With the help of members on the ExcelForum, I have managed to come up with a code which:

Finds the last column in the worksheet, then colours every strikethrough text blue, and every underlined text in red in each cell, from the identified first row of the last column, up until the last row of the last column. Below is my working code.

I'm just wondering if there is anyway to optimise the colouring process? It roughly takes 3minutes to process 700 lines within the worksheet, within the identified column range.

Thank you in advance

Sub Button2_Click()

GetLastCell

End Sub

Function GetLastCell() As Range

    Dim LastColumn As Long
    Dim LastRow As Long
    Dim cl As Range
    Dim FirstRow As String
    Dim LastCell As Range
    Dim rng As Range
    Dim i As Long

    i = 1
    
    If WorksheetFunction.CountA(Cells) > 0 Then
      LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
      Set LastCell = Cells(LastRow, LastColumn)
    End If
        
    Set GetLastCell = LastCell
    FirstRow = Split(Columns(LastColumn).Address(0, 0), ":")(0) & "1" & ":" & GetLastCell.Address

    Set rng = Range(FirstRow)
   
    For Each cl In rng.Cells
    
    For i = 1 To Len(cl.Value)
        If cl.Characters(i, 1).Font.Strikethrough Then
            cl.Characters(i, 1).Font.Color = vbBlue
        ElseIf cl.Characters(i, 1).Font.Underline = xlUnderlineStyleSingle Then
            cl.Characters(i, 1).Font.Color = vbRed
        End If
    Next i, cl
    
   
End Function