code running to slow and to long

hi guys
i have the following code

Sub Cur_4()
    Application.ScreenUpdating = False
    Dim Currency_Symbol As String, CellFormat As String
    Dim Percent As Boolean, FormatCell As Boolean
    Dim myrange As Range, cell As Range
    Dim startrow As Long, endrow As Long

    Currency_Symbol = Worksheets("Data Input Area").Range("Q8")
    Percent = (InStr(1, Currency_Symbol, "%") > 0)
   Set myrange = Sheets("Data Input Area").Range("D9:R6000")
   
For Each cell In myrange
    If IsNumeric(cell.Value) Then
        CellFormat = cell.NumberFormat
        If CellFormat <> "General" Then
        FormatCell = False
        If InStr(1, CellFormat, "%") = 0 And Not Percent Then FormatCell = True
        If Abs(cell.Value) >= 1 And Not Percent Then FormatCell = True
        If Abs(cell.Value) <= 1 And Percent Then FormatCell = True
        
        If FormatCell Then
        If Percent Then
        cell.NumberFormatLocal = "0.0%;[Red]-0.0%"
        Else
        cell.NumberFormatLocal = Currency_Symbol & "  #,##0.0;" & Currency_Symbol & "  [Red](#,##0.0)"
        End If
        End If
        End If
        End If
    Next
    Application.ScreenUpdating = True
    
End Sub

my issue is that the when i run the code it take it too long to be completed , and more then once it cause the workbook to stop working ans shut off excel , no idea why, is that because the size of the range D9:R6000 that the code need to verify or what ?? is there any way to improve that code so it will not take it so long to run ?