Optimize Excel Code - Too many FOR NEXT Loops

Your loops are hopeless...
e.g.

Dim Cell As Range
For Each Cell In ThisWorkbook.Worksheets("Main").Range("A:A")
If Cell.Value Like "*Rec ID" Then Cell.Font.Color = vbBlue
Next Cell

For Each Cell In ThisWorkbook.Worksheets("Main").Range("A:A")
If Cell.Value Like "*Rec ID" Then Cell.Font.Bold = True
Next Cell

You are looping entire column...
Find method.
eg

Sub Formatting_click()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = vbBlue
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 0)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 0)
    .Range("AM1:BX2").Interior.Color = RGB(128, 255, 0)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = vbBlue
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

Lastrow = ThisWorkbook.Worksheets("After").Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Long, rr As Long

    For r = 3 To Lastrow
        For rr = 1 To 37
            If rr = 1 Then
                If .Cells(r, rr).Value Like "" Then .Cells(r, 1).Value = "Deleted"
            End If
            If .Cells(r, rr).Value <> .Cells(r, rr + 38).Value Then .Cells(r, rr).Font.Color = vbRed
        Next
    Next r
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
Call ProtectAllSheets

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = Empty
End With

End Sub

You also need to review "Sub Summarize_click()"