Option Explicit
'разработка от: bedvit-Виталий Б.
'для форума: http://www.planetaexcel.ru/forum
'версия: 11 от 14/06/2020
'действие: Перевести условное форматирование в обычное для текущего листа - 0(False), для всей книги - 1(True)
'если 0 (для текущего листа) - обрабатывается выделенный диапазон, если диапазон из одной ячейки - весь лист.
'если 1 (для всей книги) - обрабатывается всё условное форматирование
'сохраняет структуру/группировку листа, правильное форматирование в объединенных ячейках с непечатными символами

Sub RUN(): ConditionalFormatToFormat 0: End Sub

Sub ConditionalFormatToFormat(Optional AllWorksheets As Boolean = False)
Dim W As String, t As String, tW As String, tP As String, WS As Worksheet, Rn As Range, ac, R As Range, A As Long, MaxCol As Long, MaxRow As Long, MC, SourceRange As Boolean
If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", vbExclamation + vbYesNo) = vbYes Then
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
    W = ActiveWorkbook.name ': S = ActiveSheet.name
    On Error Resume Next 'обработка ошибок в случае отсутствия условного формата на листе
    t = Environ("temp") & "\" & CreateObject("Scripting.FileSystemObject").GetTempName()
    tW = t & ".htm" 'TempWorkbook
    tP = t & ".files" 'TempPath
    
    If AllWorksheets Then 'если обрабатывваем все листы
        For Each WS In Worksheets 'если для всех листов - открываем скрытые листы
            WS.Visible = True
        Next
        'сохраняем в .htm. только для все книги сохраняется структура листа и правильное форматирование в объединенных ячейках с непечатными символами
        With ActiveWorkbook.PublishObjects.Add(xlSourceWorkbook, tW, "", "", xlHtmlStatic, "", ""): .Publish (True): .AutoRepublish = False: End With
        Workbooks.Open FileName:=tW
        
        For Each WS In Workbooks(W).Worksheets 'проходим по всем листам
            Err.Clear
            Set Rn = WS.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            GoSub Go_
        Next
        
        Workbooks(Dir(tW)).Close 0
    Else 'выделенный диапазон
        Set WS = ActiveSheet
        If Selection.CountLarge = 1 Then Set Rn = WS.Cells.SpecialCells(xlCellTypeAllFormatConditions) Else Set Rn = Selection.SpecialCells(xlCellTypeAllFormatConditions)
        
        For A = 1 To Rn.Areas.count 'проверяем на полный столбец или строку для сохранения структуры
            If MaxCol < Rn.Areas(A).Columns.count Then MaxCol = Rn.Areas(A).Columns.count
            If MaxRow < Rn.Areas(A).Rows.count Then MaxRow = Rn.Areas(A).Rows.count
        Next
        
        Application.FindFormat.MergeCells = True 'ищем объединенные ячейки
        If Not Rn.Find(What:="", SearchFormat:=True) Is Nothing Or MaxCol = ActiveSheet.Columns.count Or MaxRow = ActiveSheet.Rows.count Then ' если сохраняем структуру
            Workbooks(W).Theme.ThemeColorScheme.Save (tW) 'сохраняем цветовую схему
            WS.Copy
            Application.Wait (Now + 1 / 86400) ' ждем одну секунду от записи до открытия этого же файла.
            ActiveWorkbook.Theme.ThemeColorScheme.Load (tW) 'загружаем цветовую схему
            ActiveWorkbook.SaveAs tW, xlHtml 'сохраняем в .htm. только для всей книги сохраняется структура листа и правильное форматирование в объединенных ячейках с непечатными символами
            Workbooks(Dir(tW)).Close
            Workbooks.Open FileName:=tW
            GoSub Go_
            Workbooks(Dir(tW)).Close 0
        Else 'если нет условного форматирования в объединенных ячейках и в полных строках/столбцах
            SourceRange = True
            GoSub Go_
        End If
    End If
    
    CreateObject("Scripting.FileSystemObject").DeleteFolder (tP)
    Kill tW
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: .StatusBar = False: End With
End If
Exit Sub

Go_:
If Err = 0 Then
    Sheets(WS.name).Select
    For A = 1 To Rn.Areas.count
        Set R = Rn.Areas(A)
        If SourceRange Then
            With ActiveWorkbook.PublishObjects.Add(xlSourceRange, tW, WS.name, R.Address, xlHtmlStatic, W, ""): .Publish (True): .AutoRepublish = False: End With
            Workbooks.Open FileName:=tW
            Range(Cells(1, 1), Cells(R.Rows.count, R.Columns.count)).Copy:  R.PasteSpecial Paste:=xlPasteFormats 'Workbooks(W).Sheets(S).Range(R(1, 1).Address, R(R.Rows.count, R.Columns.count).Address).PasteSpecial Paste:=xlPasteFormats
            Workbooks(Dir(tW)).Close 0
        Else
            Range(R(1, 1).Address, R(R.Rows.count, R.Columns.count).Address).Copy:  R.PasteSpecial Paste:=xlPasteFormats
        End If
        Application.CutCopyMode = False
    Next
    Rn.Cells.FormatConditions.Delete 'удаляем условное форматирование
    Workbooks(W).Activate: Rn.Select 'выделяем обработанный диапазон
    Workbooks(Dir(tW)).Activate
End If
Return
End Sub