Jack Famous, благодарю за наводку!
В результате у меня получился рабочий макрос,
но проблема в том, что если на некоторых ячейках уже есть форматирование
(например, ячейки покрашены красным), то при срабатывании макроса это форматирование пропадает.
Существует ли возможность копировать/вставлять только условное форматирование?
Спасибо!
Вот как выглядит получившийся у меня макрос:
В результате у меня получился рабочий макрос,
но проблема в том, что если на некоторых ячейках уже есть форматирование
(например, ячейки покрашены красным), то при срабатывании макроса это форматирование пропадает.
Существует ли возможность копировать/вставлять только условное форматирование?
Спасибо!
Вот как выглядит получившийся у меня макрос:
Код |
---|
Option Explicit 'Def - все переменные в нижеследующих сабах, начинающиеся с соответствующей буквы автоматически становятся заданного типа DefBool O '(Boolean) True (-1) or False (0) DefByte B '(Byte) [1 байт] целые положительные от 0 до 255 DefInt I '% (Integer) [2 байта] целые от -32768 до 32767 DefLng L '& (Long) [4 байта] целые от -2'147'483'648 до 2'147'483'647 DefSng N '! (Single) [4 байта] дробные от -3,402'823*10^38 до -1,401'298*10^-45 и от 1,401'298*10^-45 до 3,402'823*10^38 DefDbl E '# (Double) -1.79769313486231E308 to -4.94065645841247E-324 for negative values; 4.94065645841247E-324 to 1.79769313486232E308 for positive values. DefDate D '(Date) [8 байт] дата и/или время DefStr S '$ [по 2 байта за символ] (String) DefCur U '@ [8 байт] (Currency) -922,337,203,685,477.5808 to 922,337,203,685,477.5807 DefObj J 'Object DefVar V 'Variant 'DefLngPtr X 'LongPtr integer on 32-bit systems: Signed 32-bit (4-byte) numbers ranging in value from -2,147,483,648 to 2,147,483,647 on 32-bit systems 'DefLngLng Y 'LongLong integer on 64-bit systems: Signed 64-bit (8-byte) numbers ranging in value from -9,223,372,036,854,775,808 to 9,223,372,036,854,775,807 on 64-bit systems Sub Борьба_с_дублями_УФ() Dim o_Экран Dim L_номер_последней_заполненной_строки, L_якорь, L_строка Dim i_Столбец Dim rng_Весь_диапазон As Range, rng_Исходная_Строка As Range, rng_Строка2 As Range, rng_Очищаемый_диапазон As Range o_Экран = Application.ScreenUpdating 'приравнять переменную текущему стаутсу обновления экрана Лист1.Activate 'активировать Лист1 If o_Экран = True Then Application.ScreenUpdating = False 'если обновление экрана включено, то выключить обновление экрана With ActiveSheet L_строка = ActiveCell.Row: i_Столбец = ActiveCell.Column 'определить координаты текущей активной ячейки L_якорь = ActiveWindow.ScrollRow 'определить самую верхнюю видимую строку (на текущем экране) L_номер_последней_заполненной_строки = .UsedRange.Cells(Rows.Count, "C").End(xlUp).Row 'определить номер последней строки в столбце C Set rng_Исходная_Строка = .Range(Cells(9, "A"), Cells(9, "R")) 'задать исходную (эталонную) строку Set rng_Весь_диапазон = .Range(Cells(9, "A"), Cells(L_номер_последней_заполненной_строки, "R")) 'задать весь диапазон Set rng_Очищаемый_диапазон = .Range(Cells(10, "A"), Cells(L_номер_последней_заполненной_строки, "R")) 'задать диапазон, на котором может стоять "лишнее" УФ rng_Очищаемый_диапазон.FormatConditions.Delete 'удалить форматы с диапазона, к которому будет применяться УФ (кроме эталонной строки) rng_Исходная_Строка.Copy 'копировать форматы из исходной (эталонной) строки rng_Весь_диапазон.PasteSpecial Paste:=xlPasteFormats 'вставить форматы Application.CutCopyMode = False 'убрать копирование ActiveSheet.PageSetup.PrintArea = .Range(Cells(1, 1), Cells(L_номер_последней_заполненной_строки, "R")).Address 'задать область печати .Cells(L_строка, i_Столбец).Select 'активировать ячейку, которая была активна изначально ActiveWindow.ScrollRow = L_якорь 'открутить экран по вертикали до первоначального положения End With Application.ScreenUpdating = o_Экран 'вернуть первоначачльный статус обновления экрана End Sub |
Wo unrecht zu recht wird ist widerstand pflicht.