Option Explicit
Option Private Module
'====================================================================================================
' Процедура для заливки НЕПУСТЫХ ячеек ВИДИМОГО диапазона АКТИВНОГО листа, в соответствии с их типом
' Заливка происходит на создаваемой КОПИИ активного листа (безопасно)
' Существующая заливка на КОПИИ листа(руками или УФ) будет удалена. Фигуры также будут удалены
Sub ColorMap()
Dim rng As Range, cl As Range
Dim x, arrColor(), arrType(17) ' order like CellType: 0/10=Empty; 1/11=Error; 2/12=Boolean; 3/13=String;  4/14=Num; 5/15=Date; 6/16=Time; 7/17=DateTime
Dim tx$, t!, tt!, i&, nCl&

tt = Timer
't = Timer
    Set rng = ActiveSheet.UsedRange             ' работаем со всей областью листа
    If Not FILE_GetFullVisibleCells(rng) Then Exit Sub ' если видимых НЕпустых ячеек нет, то выходим с сообщением (из функции)
'Debug.Print "Get Full:", Format$(Timer - t, "0.00 sec")

't = Timer
    For Each cl In rng
        i = FILE_CellType(cl)           ' определяем тип ячейки (0-7; 10-17), но 0 быть не может, т.к. пустые ячейки без формул исключены из диапазона
        x = arrType(i)                  ' получаем содержимое arrType по заданному индексу (тип ячейки)
        tx = cl.Address(0, 0, xlA1)     ' запоминаем ядрес ячейки в переменную

        If IsArray(x) Then              ' если это массив (создан ранее) …
            ReDim Preserve x(UBound(x) + 1) ' увеличиваем массив на 1 элемент
            x(UBound(x)) = tx               ' записываем в свободное место новый адрес
            arrType(i) = x                  ' кладём массив обратно в arrType
        Else                            ' если массива ещё нет …
            arrType(i) = Array(tx)          ' создаём массив из одного текущего адреса
        End If
    Next cl

nCl = rng.Count: Set rng = Nothing
'Debug.Print "Get Types:", Format$(Timer - t, "0.00 sec")

't = Timer
    FILE_Parameters                     ' запоминаем параметры
    ActiveSheet.Copy After:=ActiveSheet ' копируем лист после активного
    ActiveSheet.DrawingObjects.Delete   ' удаляем фигуры
    Cells.FormatConditions.Delete       ' удаляем УФ
    Cells.Interior.ColorIndex = xlNone  ' очищаем заливку
    Cells.Font.Color = vbBlack          ' устанавливаем чёрный цвет шрифта
'Debug.Print "Create Sheet:", Format$(Timer - t, "0.00 sec")

't = Timer
'                —  1 vEr  2 vBool  3 vStr    4 vNum          5 vDate        6 vTime 7 vDT     —  —  10 fEmp           11 fEr        12 fBool   13 fStr       14 fNum    15 fDate  16 fT   17 fDateTime
arrColor = Array(0, vbRed, vbBlack, rgbBrown, rgbDarkMagenta, rgbDarkOrange, vbBlue, rgbGreen, 0, 0, rgbDarkSlateGray, rgbLightPink, rgbSilver, rgbBurlyWood, vbMagenta, vbYellow, vbCyan, vbGreen) ' массив цветов фона для типов

    For i = 1 To UBound(arrType)                                ' цикл по всем элементам массива arrType
        If IsArray(arrType(i)) Then                                 ' если очередной элемент является массивом, значит для соответствующего типа есть ячейки
            For Each x In FILE_RangesFromAddress(Join(arrType(i), ","))   ' цикл по всем "укрупнённым" диапазонам
                x.Interior.Color = arrColor(i)                              ' красим фон
                If i < 8 Then x.Font.Color = vbWhite                        ' если это типы 1-7, то это значения и надо красить шрифт в белый
            Next x
        End If
    Next i
'Debug.Print "Paint:", Format$(Timer - t, "0.00 sec")

FILE_Parameters True    ' восстанавливаем параметры
MsgBox "Cells paint:" & Format$(nCl, "### ### ### ### ###"), vbInformation, Format$(Timer - tt, "0.00 sec")
End Sub
'====================================================================================================

Option Explicit
Option Private Module
'====================================================================================================
Dim F_Calc&, F_SU As Boolean    ' переменные для "запоминания" в процедуре «FILE_Parameters»
'====================================================================================================
' Функция принимает лист и строку адресов с этого листа в виде одномерного массива, а возвращает массив "укрупнённых" адресов
' Если лист не передан, то принимается активный лист
'====================================================================================================
Function FILE_RangesFromAddress(ByVal txAdr$, Optional sh As Worksheet) As Range()
Dim arr() As Range
Dim l&, n&, i&, p&, m&

If sh Is Nothing Then Set sh = ActiveSheet
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): Set arr(0) = sh.Range(txAdr): GoTo fin
m = l - 256

ReDim arr(l \ 200): n = -1
    Do
        i = InStrRev(txAdr, ",", p + 256)
        n = n + 1: Set arr(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
        p = i

        If p > m Then
            n = n + 1: Set arr(n) = sh.Range(Right$(txAdr, l - p))
            ReDim Preserve arr(n): GoTo fin
        End If
    Loop

fin: FILE_RangesFromAddress = arr
End Function
'====================================================================================================
' Функция определения типа ячейки (возвращает код)
' Коды значений: 0(Em) = Empty; 1(Er) = Error; 2(B) = Boolean; 3(S) = String;  4(N) = Num; 5(D) = Date; 6(T) = Time; 7(DT) = DateTime
' Если в ячейке формула, то вернёт 10 + код значения
Function FILE_CellType(cl As Range) As Long
Dim v, x, fF As Boolean

If cl.HasFormula Then fF = True
v = cl.Value
If IsError(v) Then FILE_CellType = 1: GoTo fin
If Len(v) = 0 Then GoTo fin
If VarType(v) = vbString Then FILE_CellType = 3: GoTo fin
If VarType(v) = vbBoolean Then FILE_CellType = 2: GoTo fin
On Error Resume Next

    If IsNumeric(v) Then                                            ' если прошло проверку на "ЧИСЛО" …
        x = CDbl(v): If Err Then FILE_CellType = 3: GoTo fin            ' если преобразование в число вызвало ошибку, то это СТРОКА
        If v Like "*[de]*" Then FILE_CellType = 3: GoTo fin             ' если "число" содержит буквы "d" или "e", то это просто форма записи экспоненты и считаем СТРОКОЙ
        If cl.NumberFormat Like "*:*" Then FILE_CellType = 6: GoTo fin  ' если в формате ячейки с "числом" есть ":", то это ВРЕМЯ
        FILE_CellType = 4                                                 ' если ничего не подошло, то это ЧИСЛО
    ElseIf IsDate(v) Then                                           ' если прошло проверку на "ДАТУ" …
        x = CDbl(v): If Err Then FILE_CellType = 3: GoTo fin            ' если преобразование в число вызвало ошибку, то это СТРОКА
        If x = 0 Then FILE_CellType = 4: GoTo fin                       ' 0 не может быть датой, считаем числом
        If x < 1 Then FILE_CellType = 6: GoTo fin                       ' <0 не может быть датой, считаем временем
        If x = Fix(x) Then FILE_CellType = 5: GoTo fin                  ' если получено целое число, то это ДАТА
        FILE_CellType = 7                                               ' если ничего не подошло, то это ДАТАВРЕМЯ
    End If

fin: On Error GoTo 0
If fF Then FILE_CellType = 10 + FILE_CellType
End Function
'====================================================================================================
' Функция принимает диапазон для поиска, и ОСТАВЛЯЕТ в нём только ВИДИМЫЕ и НЕпустые области (формулы и значения, в том числе ошибки)
' Возвращает False, если ВИДИМЫХ и НЕпустых нет
Function FILE_GetFullVisibleCells(rng As Range) As Boolean
Dim rngSee As Range, rngV As Range, rngF As Range

    If rng.Count = 1 Then                           ' если передеана 1 ячейка
        If rng.EntireRow.Hidden Then GoTo no            ' если строка скрыта, то видимых нет
        If rng.EntireColumn.Hidden Then GoTo no         ' если столбец скрыт, то видимых нет
        If IsError(rng.Value2) Then GoTo yes            ' если ошибка, то забираем и выходим
        If Len(rng.Value2) Then GoTo yes                ' если непустая, то забираем и выходим
        If rng.HasFormula Then GoTo yes Else GoTo no    ' если есть формула, то забираем и выходим
    End If

On Error Resume Next
Set rngSee = rng.SpecialCells(xlCellTypeVisible)        ' диапазон видимых ячеек из переданного диапазона
Set rngV = rngSee.SpecialCells(xlCellTypeConstants, 23) ' диапазон значений из видимых
Set rngF = rngSee.SpecialCells(xlCellTypeFormulas, 23)  ' диапазон формул из видимых
On Error GoTo 0
If rngSee Is Nothing Then GoTo no                       ' если видимых нет, то выходим с ссобщением

    If rngV Is Nothing Then                         ' если значений нет …
        If rngF Is Nothing Then GoTo no                     ' если и формул нет, то выходим
        Set rng = rngF: GoTo yes                            ' берём формулы и выходим
    Else                                            ' если значения есть …
        If rngF Is Nothing Then Set rng = rngV: GoTo yes    ' если формул нет, то берём значения и выходим
        Set rng = Union(rngV, rngF)                         ' объединяем формулы и значения
    End If

yes: FILE_GetFullVisibleCells = True: Exit Function
no: MsgBox "There is no current cells in range" & vbLf & rng.Address(0, 0, xlA1, True), vbCritical, "NO DATA"   ' выводим сообщение при неудаче
End Function
'====================================================================================================
' процедура запоминает параметры обновления экрана и пересчёта и выставляет отключение экрана и ручной пересчёт
' при передаче аргумента, возвращает запомненные параметры
Sub FILE_Parameters(Optional iReturn As Boolean)
    If iReturn Then                                                                     ' если возвращаем параметры …
        Application.Calculation = F_Calc                                                    ' возвращаем тип пересчёта
        Application.ScreenUpdating = F_SU                                                   ' возвращаем обновление экрана
    Else                                                                                ' если запоминаем …
        F_SU = Application.ScreenUpdating:  Application.ScreenUpdating = False              ' запоминаем в переменную текущее обновление экрана и отключаем его
        F_Calc = Application.Calculation:   Application.Calculation = xlCalculationManual   ' запоминаем в переменную тип пересчёта в книге и выставляем ручной
    End If
End Sub
'====================================================================================================