Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1 2 След.
RSS
Перевести условное форматирование в обычное - VBA., Универсальный и специализированные варианты.
 
Всем привет! Предлагаю вариант перевода УФ в обычное за исключением гистограмм и значков, т.к. в стандартном их нет. Относительно универсальный, быстрый и простой.
Код прилагаю, замечания, если по делу приветствуются. Свои варианты, если есть - тоже :)
Скрытый текст
Алгоритм собственный, если с кем-то стал соавтором - не умышленно.
Сохранение гистограмм и значков  - реально ли?
«Бритва Оккама» или «Принцип Калашникова»?
 
Доброе время суток
Спасибо. Пригодится.
 
Я единственное что не понял, так это почему:
Код
Application.AddIns.Parent.UserLibraryPath
а не просто
Код
Application.UserLibraryPath
и почему
Код
Range(Sel.Address).FormatConditions.Delete
вместо
Код
Sel.FormatConditions.Delete
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
The_Prist, от вас ничего не скроешь! Приятно, черт побери) Согласен, и с первым (пошел через AddIns, не знал про короткую запись, я так понял результат одинаковый в любых случаях?), и со вторым (были варианты через Range, потом перешел к Objects, остался кусочек незамеченный :) )
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
я так понял результат одинаковый в любых случаях?
не в любых, а в обоих :) Просто запись Application.AddIns.Parent сама по себе возвращает объект Application. Поэтому нет смысла делать её такой.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Подкорректированный вариант:
Скрытый текст
«Бритва Оккама» или «Принцип Калашникова»?
 
bedvit, спасибо большое! Пригодилось!
Улыбнись.
 
falmrom, рад этому событию. Код должен жить и работать, ибо тогда для чего он.
«Бритва Оккама» или «Принцип Калашникова»?
 
Если наши эксперты The_Prist, и Андрей VG, признают это дельным давайте в копилку запихнем работу bedvit, надо золотую коллекцию пополнять
Лень двигатель прогресса, доказано!!!
 
Коллеги, спасибо за оценку.
Вот последний вариант.
В отличии от первого, временный файл сохраняется в пользовательский "temp", где гарантированы права записи, а не в папке для надстроек. Т.е. вариант, на случай, когда папка с надстройками с правами только "чтение" (плохо представляю такое развитие ситуации, т.к. эта папка тоже под пользователем).
Вообщем все варианты рабочие, на вкус и цвет, выбирайте сами.

Код
'разработка от: bvv(bedvit)-Виталий Б.
'для форума: http://www.planetaexcel.ru/forum
'версия: 2 от 08/03/2019
'действие: Перевести условное форматирование в обычное (выделенный диапазон), если выделена одна ячейка - обрабатывается весь лист.
Option Explicit
Sub Перевести_УФ_в_обычное()
Dim AWName, ASName, Add_WName, r, ac
If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", vbExclamation + vbYesNo) = vbYes Then
If Selection.CountLarge = 1 Then Set r = Cells Else Set r = Selection
If r Is Nothing Then Exit Sub
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: ac = .Calculation: .Calculation = -4135: .StatusBar = "BVV: обработка данных...": End With
    AWName = ActiveWorkbook.name:  ASName = ActiveSheet.name
    Randomize:    Add_WName = Environ("temp") & "\_" & Int((1000000000 * Rnd) + 1000000000) & ".mht"
    With ActiveWorkbook.PublishObjects.Add(xlSourceRange, Add_WName, ASName, r.Address, xlHtmlStatic, AWName, ""): .Publish (True): .AutoRepublish = False: End With
    Workbooks.Open FileName:=Add_WName, UpdateLinks:=False, ReadOnly:=True
    Range(Cells(1, 1), Cells(r.Rows.Count, r.Columns.Count)).Copy
    Workbooks(AWName).Sheets(ASName).Range(r(1, 1).Address).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    ActiveWorkbook.Close 0: Kill Add_WName
    r.FormatConditions.Delete
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: .StatusBar = False: End With
End If
End Sub
Изменено: bedvit - 8 мар 2019 14:36:41
«Бритва Оккама» или «Принцип Калашникова»?
 
bedvit, Приветвую, а чего временный не стандартно?
Код
    Add_WName = Environ("temp") & "\" & CreateObject("Scripting.FileSystemObject").GetTempName() & ".mht"
Изменено: БМВ - 8 мар 2019 14:52:16
По вопросам из тем форума, личку не читаю.
 
БМВ, Приветствую! Можно и через FSO. Доп. библиотеку цеплять, но в данном случае это не принципиально. Опять же на вкус и цвет. Вариант красивый.
Изменено: bedvit - 9 мар 2019 14:37:58
«Бритва Оккама» или «Принцип Калашникова»?
 
Версия с сохранением структуры листа (группировки столбцов/строк) в случаях выделения целой строки или столбца или всего листа (с данными).
Код
'разработка от: bvv(bedvit)-Виталий Б.
'для форума: http://www.planetaexcel.ru/forum
'версия: 8 от 24/05/2019
'действие: Перевести условное форматирование в обычное (выделенный диапазон), если выделена одна ячейка - обрабатывается весь лист.
'сохраняет структуру/группировку листа.
Option Explicit
Sub Перевести_УФ_в_обычное()
Dim W As String, S As String, tW As String, Rn As Range, ac, R As Range, A As Long
If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", vbExclamation + vbYesNo) = vbYes Then
    W = ActiveWorkbook.name: S = ActiveSheet.name
    Err.Clear: On Error Resume Next 'обработка ошибок в случае отсутствия условнного формата на листе
    If Selection.CountLarge = 1 Then Set Rn = Cells.SpecialCells(xlCellTypeAllFormatConditions) Else Set Rn = Selection.SpecialCells(xlCellTypeAllFormatConditions)
    If Err > 0 Then MsgBox Err.Description
    If Rn Is Nothing Or Err > 0 Then Exit Sub
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: ac = .Calculation: .Calculation = -4135: .StatusBar = "BVV: обработка данных...": End With
    For A = 1 To Rn.Areas.Count
        Set R = Rn.Areas(A)
        Randomize: tW = Environ("temp") & "\~$CF" & Int((1000000000 * Rnd) + 1000000000) & ".mht"
        If R.Columns.Count = ActiveSheet.Columns.Count Or R.Rows.Count = ActiveSheet.Rows.Count Then ' если сохраняем структуру
            Sheets(S).Copy
            ActiveWorkbook.SaveAs FileName:=tW, FileFormat:=xlWebArchive, CreateBackup:=False
            ActiveWorkbook.Close 0
            Workbooks.Open FileName:=tW
            Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).Copy:  Workbooks(W).Sheets(S).Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).PasteSpecial Paste:=xlPasteFormats
        Else
            With ActiveWorkbook.PublishObjects.Add(xlSourceRange, tW, S, 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:  Workbooks(W).Sheets(S).Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).PasteSpecial Paste:=xlPasteFormats
        End If
        Application.CutCopyMode = False
        ActiveWorkbook.Close 0: Kill tW
        R.Select: R.FormatConditions.Delete
    Next
    Rn.Select
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: .StatusBar = False: End With
End If
End Sub
Изменено: bedvit - 24 май 2019 12:33:21
«Бритва Оккама» или «Принцип Калашникова»?
 
bedvit, благодарю за готовое решение!
The_Prist, не сравнивали по скорости со своим вариантом?
Реквизиты для благодарности и контакты для связи — в профиле
 
Цитата
Версия с сохранением структуры листа (группировки столбцов/строк) в случаях выделения целой строки или столбца или всего листа (с данными).
Прошу извинить меня, что влезаю...
@bedvit можно мне обнаглеть... и попросить показать как применить к 40 листам в книге?
Что-то подобное...
Код
Sub all_sheets()
Dim ws As Worksheet
For Each ws In Worksheets
    'code...
Next ws
End Sub
Спасибо!
Изменено: Alex D - 22 май 2019 13:47:19
 
Цитата
Alex D написал:
применить к 40 листам в книге?
как-то так:
Код
'разработка от: bvv(bedvit)-Виталий Б.
'для форума: http://www.planetaexcel.ru/forum
'версия: 9 от 24/05/2019
'действие: Перевести условное форматирование в обычное для всей книги
'сохраняет структуру/группировку листа.
Sub Перевести_УФ_в_обычное_вся_книга()
Dim W As String, S As String, tW As String, ws As Worksheet, Rn As Range, ac, R As Range, A As Long
If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", vbExclamation + vbYesNo) = vbYes Then
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: ac = .Calculation: .Calculation = -4135: .StatusBar = "BVV: обработка данных...": End With
    W = ActiveWorkbook.name
    On Error Resume Next 'обработка ошибок в случае отсутствия условнного формата на листе
    For Each ws In Worksheets
        Err.Clear
        ws.Visible = True: S = ws.name: Set Rn = ws.Cells.SpecialCells(xlCellTypeAllFormatConditions)
        If Err = 0 Then
            For A = 1 To Rn.Areas.Count
                Set R = Rn.Areas(A)
                Randomize: tW = Environ("temp") & "\~$CF" & Int((1000000000 * Rnd) + 1000000000) & ".mht"
                If R.Columns.Count = ActiveSheet.Columns.Count Or R.Rows.Count = ActiveSheet.Rows.Count Then
                    Sheets(S).Copy
                    ActiveWorkbook.SaveAs FileName:=tW, FileFormat:=xlWebArchive, CreateBackup:=False
                    ActiveWorkbook.Close 0
                    Workbooks.Open FileName:=tW
                    Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).Copy:  Workbooks(W).Sheets(S).Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).PasteSpecial Paste:=xlPasteFormats
                Else
                    With ActiveWorkbook.PublishObjects.Add(xlSourceRange, tW, S, 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:  Workbooks(W).Sheets(S).Range(R(1, 1).Address, R(R.Rows.Count, R.Columns.Count).Address).PasteSpecial Paste:=xlPasteFormats
                End If
                Application.CutCopyMode = False
                ActiveWorkbook.Close 0: Kill tW
            Next
            Rn.Select: Cells.FormatConditions.Delete 'удаляем условное форматирование со всего листа
        End If
    Next
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: .StatusBar = False: End With
End If
End Sub
Изменено: bedvit - 24 май 2019 12:33:41
«Бритва Оккама» или «Принцип Калашникова»?
 
Не понравилось мне как работает код на объединенных ячейках при выделении всего столбца. Переделал код для листа п.13 и код для всей книги п.16
Тестируйте.
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Тестируйте.
Доброго дня bedvit,
Прогнал, [версия: 7 от 22/05/2019] по 41 листу. cca 7 мин. Ошибки, нет.

Update:

Фаил с 9 MB подрос до 250 MB
Сохронял, как новый .xls / .xlsm - тоже самое

Спасибо Вам  и форуму!
Изменено: Alex D - 23 май 2019 14:53:10
 
Цитата
Alex D написал:
Фаил с 9 MB подрос до 250 MB
Это из-за чего? из-за перевода формата? Такого сильного роста не замечал. Сможете небольшой пример (файл) приложить, который увеличивается в размерах при сохранении форматирования?
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Это из-за чего? из-за перевода формата?
После удаление всего лишнего  мой фаил cca 700 KB, нельзя зацепить на форуме (фаил > 100 KB ) + security reasons не дают мне этого сделать.

После макроса.
Я обратил внимание, если выделить все листы, далее HOME -> Clear -> Clear Formats -> Save этот же фаил, размер упал с 9 MB до 7 MB
Понятно, что все форматы которые были стерлись и фаил стал меньше.
Я не специалист... только учусь... но такое ощущение что после макроса все "форматирования" дублируются.
Изменено: Alex D - 23 май 2019 16:20:43
 
Оптимизировал некоторые моменты. Поправил код для листа см. п.13 и код для всей книги см. п.16
Не меняет форматирование на защищенных листах.
Тестируйте.
Сколько теперь времени выполняется и каков теперь размер исходного и конечного файлов?
Изменено: bedvit - 24 май 2019 12:38:08
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Оптимизировал некоторые моменты.
51 лист в книге;
время на обработку, cca 2 мин
размер файла initial 9.7 MB -> после макроса 10.1 MB. (+сca 4%)
В течении дня буду тестировать еще. Обязательно дам знать.

Update от 5/27/19 работает стабильно.
Ошибок нет.
Спасибо огромное!
Изменено: Alex D - 27 май 2019 12:22:12
 
Доброго дня! Макрос прекрасно работал, пока не обновили excel/ Теперь стоит Professional. Подскажите, что можно поменять в макросе, чтобы можно было его применять к новому excel (вернуться обратно к обычному нет возможности,  Professional нужен по работе).
Изменено: julli_ya - 3 дек 2019 16:47:31
 
julli_ya, может просто разрешить выполнение макросов? Разницы между версиями - нет (для данного кода).
«Бритва Оккама» или «Принцип Калашникова»?
 
Off
bedvit,  Виталий, какой Вы право не профессиональный  :D
По вопросам из тем форума, личку не читаю.
 
Привет!
Цитата
bedvit написал:
Переделал код для листа п.13 и код для всей книги п.16
Чтобы два раза не вставать :-)
Скрытый текст
Сравнение прайсов, таблиц - без настроек
 
Модераторы, добавьте в копилку идей
 
Цитата
bedvit написал:
Изменено: bedvit  - 24 Май 2019 12:33:41
Спасибо большое, пригодилось!

Заметил, что при переформатировании, если ячейки содержат непечатные символы (перенос строки, например), происходит нежелательное наложение ячеек верхних на нижние (объединение нескольких ячеек по вертикали). Поскольку моя задача была не только в переводе условного форматирования в обычное, но еще и в избавлении книги от формул, то решил при помощи предварительной очистки от формул и от непечатных символов

Код
    For Each ws In ActiveWorkbook.Worksheets
        ws.UsedRange.Value = Application.Clean(ws.UsedRange)
    Next ws
Изменено: smaxus - 14 май 2020 04:07:42
 
smaxus, да, есть такой момент. внес изменения в код, теперь форматы в объединенных ячейках с непечатными символами переносятся корректно.
Также добавил красивое решение от Михаила п.11 и реализовал возможность сохранить условное форматирование только в выделенной области текущего листа или для всей книги одним переключателем.
Код.
Код
Option Explicit
'разработка от: bedvit-Виталий Б.
'для форума: http://www.planetaexcel.ru/forum
'версия: 10 от 20/05/2020
'действие: Перевести условное форматирование в обычное для текущего листа - 0(False), для всей книги - 1(True)
'если 0 (для текущего листа) - обрабатывается выделенный диапазон, если диапазон из одной ячейки - весь лист.
'если 1 (для всей книги) - обрабатывается всё условное форматирование
'сохраняет структуру/группировку листа.

Sub RUN(): ConditionalFormatToFormat 0: End Sub

Sub ConditionalFormatToFormat(Optional AllWorksheets As Boolean = False)
Dim W As String, tW As String, WS As Worksheet, Rn As Range, ac, r As Range, A As Long
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
    On Error Resume Next 'обработка ошибок в случае отсутствия условного формата на листе
    
    If AllWorksheets Then
        For Each WS In Worksheets
            Err.Clear
            Set Rn = WS.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            GoSub Go_
        Next
    Else
        Set WS = ActiveSheet
        Err.Clear
        If Selection.CountLarge = 1 Then Set Rn = Cells.SpecialCells(xlCellTypeAllFormatConditions) Else Set Rn = Selection.SpecialCells(xlCellTypeAllFormatConditions)
        GoSub Go_
    End If
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: .StatusBar = False: End With
End If
Exit Sub

Go_:
If Err = 0 Then
    tW = Environ("temp") & "\" & CreateObject("Scripting.FileSystemObject").GetTempName()
    Workbooks.Add
    For A = 1 To Rn.Areas.count
        Set r = Rn.Areas(A):    r.Copy
        Range(r(1, 1).Address, r(r.Rows.count, r.Columns.count).Address).PasteSpecial Paste:=xlPasteValues 'значения
        Range(r(1, 1).Address, r(r.Rows.count, r.Columns.count).Address).PasteSpecial Paste:=xlPasteAllUsingSourceTheme 'формат
        Application.CutCopyMode = False
    Next
    ActiveWorkbook.SaveAs FileName:=tW, FileFormat:=xlWebArchive, CreateBackup:=False
    Workbooks(Dir(tW)).Close 0
    Workbooks.Open FileName:=tW
    For A = 1 To Rn.Areas.count
        Set r = Rn.Areas(A)
        Range(r(1, 1).Address, r(r.Rows.count, r.Columns.count).Address).Copy:  r.PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
    Next
    Workbooks(Dir(tW)).Close 0: Kill tW 
    Rn.Cells.FormatConditions.Delete 'удаляем условное форматирование
End If
Return
End Sub

Тестируйте.

p.s. Из замеченного: команда "Вставить значение и исходное форматирование", если записать в рекордере, работает так:
Код
...PasteSpecial Paste:=xlPasteAllUsingSourceTheme
...PasteSpecial Paste:=xlPasteValues
, что на объединенных ячейках вызывает ошибку "для этого все объединенные ячейки должны иметь одинаковый размер"...
если же эти команды поменять местами, все работает.  Почему разработчики не сделали такую очередность для меня загадка.
Изменено: bedvit - 20 май 2020 23:43:38
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Тестируйте.
прилагаю документ, на котором у меня
версия 9 с дополнениями из п.28 отрабатывала корректно
версия 10 отрабатывает не корректно (красит все серым)
Страницы: 1 2 След.
Читают тему (гостей: 1)
Наверх