请尝试下一个代码。它使用了两个字典来放置每种颜色（内部或字体）的Union范围。由于在特定限制后增加这样一个Union范围内的单元格数量，代码可能会大大降低速度，我添加了一个序列，当它达到500个单元格的数量时，改变现有的这种范围颜色（这不是能够处理的最大值，一种通过增加它来降低速度以改变单元格颜色的最佳选择）：

Sub DeleteFormattCond_KeepColors()
  Dim sh As Worksheet, lastR As Long, rng As Range, itCell As Range, rngCol As Range, st_time As Single
  Dim i As Long, DictBack As New Scripting.Dictionary, DictFont As New Scripting.Dictionary
  Const NoIntColor As Long = 16777215, NoFontColor As Long = 0
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row 'last filled row in A:A column
                                                       'you may keep your 4000 if you like it more...
  Set rng = sh.Range("A2:CJ" & lastR) 'set the range to be procesed
  
  On Error GoTo ErrorHndl 'to not stop on error and go to the end to reenable the below events
  With Application 'to make increase the code speed:
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With
  
  st_time = Timer
  For Each itCell In rng.cells 'iterate between all cells:
    'process and create Union ranges for DisplayFormat.Interior.Color:
     If itCell.DisplayFormat.Interior.Color <> NoIntColor Then 'exclude the empty interior:
        If Not DictBack.Exists(itCell.DisplayFormat.Interior.Color) Then
            Set DictBack(itCell.DisplayFormat.Interior.Color) = itCell 'place the first cell of future Union range
                                                                       'for a specific interior color
        Else
            Set rngCol = DictBack(itCell.DisplayFormat.Interior.Color) 'set rngCol as the existing dictionary range
            addToRange rngCol, itCell 'use this sub to add cells to the Union Range
            If rngCol.cells.count >= 500 Then 'if the Union range exceeds a specific number of cells, it slows down the speed
                rngCol.Interior.Color = itCell.DisplayFormat.Interior.Color 'drop the necessary colors in the partial range
                Set rngCol = Nothing 'to start a new range
            End If
            Set DictBack(itCell.DisplayFormat.Interior.Color) = rngCol 'place the Union range back as a dictionary item
        End If
     End If
     
    'process and create Union ranges for DisplayFormat.Font.Color (on the same mechanism as above):
     If itCell.DisplayFormat.Font.Color <> NoFontColor Then 'exclude the Automatic black color:
        If Not DictFont.Exists(itCell.DisplayFormat.Font.Color) Then
            Set DictFont(itCell.DisplayFormat.Font.Color) = itCell
        Else
            Set rngCol = DictFont(itCell.DisplayFormat.Font.Color)
            addToRange rngCol, itCell 'use this sub to add cells to the Union Range
            If rngCol.cells.count >= 500 Then
                rngCol.Font.Color = itCell.DisplayFormat.Font.Color
                Set rngCol = Nothing
            End If
            Set DictFont(itCell.DisplayFormat.Font.Color) = rngCol
        End If
     End If
  Next itCell
  
  'change the interior color for each (remainend) Union Range, at once:
  For i = 0 To DictBack.count - 1
    If Not DictBack.Items()(i) Is Nothing Then
        DictBack.Items()(i).Interior.Color = DictBack.keys()(i)
    End If
  Next i
  
  'change the font color for each (remainend) Union Range, at once:
  For i = 0 To DictFont.count - 1
    If Not DictFont.Items()(i) Is Nothing Then
        DictFont.Items()(i).Font.Color = DictFont.keys()(i)
    End If
  Next i
  
  rng.FormatConditions.Delete 'delete FormatConditions!
 
  MsgBox "Job done in " & Timer - st_time & " seconds..."
ErrorHndl:
 With Application 'reenable the events and calculation type
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
 End With
 If Err <> 0 Then MsgBox Err.Description & " - " & Err.number
End Sub

Sub addToRange(rngU As Range, rng As Range) 'the helping Sub to load each cell in the specific Union range
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

我试着注解可能无法理解的每一行代码。如果还有什么不清楚的，请不要犹豫，要求澄清。
我在一个测试范围（“A2：CJ4001”）上测试了代码，处理大约花了112秒。
现在，我忍不住要说，我希望你两周后不要再回来了......
代码需要引用Microsoft Scripting Runtime。代码可以很容易地更改为使用后期绑定，但对于如此巨大的范围，您将在速度上有所放松。如果很难做到这一点，我可以发布一段代码来自动做到这一点。
事实上，没有人知道你什么时候会回到这里，所以，请在运行上面的主代码**之前复制下一个代码并运行它。最好在那之后保存工作簿以保留引用。我认为这对未来非常有帮助：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  Application.vbE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub