Страницы: 1
RSS
Копирование цвета ячеек макросом
 
Здраствуйте.
Здесь на форуме нарыл примерно нужный код под мою задачу. Работает не совсем так, как мне надо. Подскажите пожалуйста, что нужно допилить на примере тестового файла, что во вложении.
Задача следующая: цвет диапазона A1:J10 листа 1 автоматически копировать в аналогичный (или в другой заданный явным образом). Код, что тут нашёл (диапазоны подставил свои):
Код
Sub Macros()
Dim d As Range, i&
With ['Лист1'!A1:J10] 'источник
   ReDim c(1 To .Count)
   For Each d In .Cells
       i = i + 1
       c(i) = d.Interior.Color
   Next
End With
i = 0
For Each d In ['Лист2'!A1:J10] 'приемник
   i = i + 1
   If i > UBound© Then i = 1
   d.Interior.Color = c(i)
Next
End Sub
Некорректность работы в том, что он берёт образец из ячейки A1 Листа1 и заливает этим цветом весь заданный диапазон на Листе2. Мне нужно, чтобы заливка происходила в точности так, как в диапазоне источнике. И нужно, чтобы это происходило автоматически после любого изменения на листе или по F9. Сейчас работает только по нажатию на кнопку пуска в окне макросов.
 
Цитата
Алексей П написал:
 If i > UBound© Then i = 1
удалите  будет вам счастье
Не бойтесь совершенства. Вам его не достичь.
 
с условным форматированием - не будет счастья, ждет большой облом
Код
c(i) = d.DisplayFormat.Interior.Color
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Про это можно поподробнее?

Цитата
Mershik написал: удалите  будет вам счастье
Спасибо, работает  :)  
 
подробности в строке кода сообщением выше
перенесите своим кодом эту заливку, увидите в чем облом
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Я понял, цвет не соответствует. К счастью у меня УФ отсутствует. Стандартные цвета.
 
Mershik, а как несколько диапазонов задать?
Типа такого:
Код
Sub Macros()
Dim d As Range, i&
With ['Лист1'!A1:AE1;A6:AE6;A14:AE14] 'источник
   ReDim c(1 To .Count)
   For Each d In .Cells
       i = i + 1
       c(i) = d.Interior.Color
   Next
End With
i = 0
For Each d In ['Лист2'!A1:AE1;A6:AE6;A14:AE14] 'приемник
   i = i + 1
   d.Interior.Color = c(i)
Next
End Sub

Если я правильно понял, каждый диапазон источника соответствует заданному в ответной части кода, т.е. первый первому, второй второму и т.д.
Ругается на строку ReDim c(1 To .Count)
Для каждого диапазона отдельный блок делать огромный код получится.
 
а зачем вы переспрашиваете о подробностях с УФ если, к сачстью, его у вас нет?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Алексей П написал:
Для каждого диапазона отдельный блок делать огромный код получится.
приложить нормальный файл пример где
Цитата

а как несколько диапазонов задать?
показать исходные данные и желаемый результат
Изменено: Mershik - 18.10.2020 12:06:38
Не бойтесь совершенства. Вам его не достичь.
 
Файл во вложении.
Нужно, чтобы цвет ячеек листа "1кв" копировался на листы "Печать" и "Водители". Это график выходов на работу и мне нужно, чтобы цвет переносился автоматически. Т.е. на первом листе на весь квартал выставляю его вручную, далее нужно, чтобы по кнопке или по F9 происходила заливка остальных листов (в файле примера их у меня два).
Изменено: Алексей П - 18.10.2020 12:23:56
 
На листе "Печать" файла примера ошибочно оставил кнопку <Выполнить>.
Корректный файл примера в этом сообщении.
 
Алексей П, если файлы листы идентичный может проще просто скопировать диапазон и вставить форматы и все записав его, но если нет то

Код
Sub Макрос1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cell As Range, rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
For Each cell In rng
    MyColor = cell.Interior.Color
    Worksheets("Печать").Cells(cell.Row, cell.Column).Interior.Color = MyColor
    Worksheets("Водители").Cells(cell.Row, cell.Column).Interior.Color = MyColor
Next cell
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

или так

Код
Sub Макрос2()
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Copy
Sheets("Печать").Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Водители").Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
kipBlanks:=False, Transpose:=False
End Sub
Изменено: Mershik - 18.10.2020 13:17:09
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
если файлы листы идентичный может проще просто скопировать диапазон
Нет, листы абсолютно разные.
Как только появится возможность, я попробую Ваш вариант.
Сейчас не возле компа.
В Вашем коде как-то указываются нужные диапазоны? Потому что в оригинале на первом листе ниже там ещё есть таблицы. Их копировать не нужно.
Изменено: Алексей П - 18.10.2020 13:31:22
 
Алексей П,
Цитата
Алексей П написал:
Нет, листы абсолютно разные.
так какого же фига показываете одинаковые8)
даже в правилах написано:
Цитата
  2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
поэтому не уверен что хоть один вариант Вам подойдет.
Не бойтесь совершенства. Вам его не достичь.
 
Извините, хотел уловить смысл и сделать под свои нужды.
 
Можно ли Ваш код как-то модифицировать? Вложил файл пример. Там на целевых листах сдвинуты таблицы, они должны заполняться по выполнению кода. Как можно задать необходимые мне диапазоны? Количество заливаемых ячеек идентичное у источника и у приёмников. В качестве источника необходимо брать не весь лист, а заданные диапазоны, в данном случае их три (каждый отвечает за свой месяц).
 
Алексей П, их расположение всегда такое?
Не бойтесь совершенства. Вам его не достичь.
 
Нет, это файл пример. Реальный файл другой. Диапазоны явно можно указать? Я могу выложить реальный файл, но периодически его модифицирую. Поэтому хотелось бы иметь представление, как можно подправить код в случае необходимости.
 
Алексей П, если реально у вас 3 диапазона то проще их задать явно и все и копировать форматы - сейчас покажи пару минут
Код
Sub Макрос1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cell As Range, rng As Range, rng2 As Range, rng3 As Range, sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Worksheets("1кв"): Set sh2 = Worksheets("Печать"): Set sh3 = Worksheets("Водители")
Set rng1 = sh1.Range("A2:AE9"): Set rng2 = sh1.Range("A13:AE20"): Set rng3 = sh1.Range("A24:AE31")
rng1.Copy
sh2.Range("E5").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
sh3.Range("B6").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
rng2.Copy
sh2.Range("E16").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
sh3.Range("B17").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
rng3.Copy
sh2.Range("E27").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
sh3.Range("B28").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 19.10.2020 14:06:30
Не бойтесь совершенства. Вам его не достичь.
 
Хотел загрузить файл с реальной структурой, но размер более 100кб, сайт не позволяет.
 
Алексей П, реальный файл нужно грузить только с тем что нужно для решения задачи  
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
если реально у вас 3 диапазона то проще их задать явно и все и копировать форматы
Да, диапазонов три, но целевых листов больше. В Вашем коде вижу явно заданные диапазоны, попробую подогнать под свои нужды  :)  
Спасибо за помощь!
Изменено: Алексей П - 19.10.2020 14:39:59
 
После нажатия на <кнопку> выполнения, перекидывает на один из листов с последним заполненным диапазоном. Можно сделать, чтобы не перекидывало?  
 
Алексей П, в предложенном мною коде нет никакого перехода
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
в предложенном мною коде нет никакого перехода
Видимо так просто отрабатывает заполнение. Буду пробовать. Спасибо ещё раз.
 
Алексей П, какое заполнение? вы о чем?
Не бойтесь совершенства. Вам его не достичь.
 
Не смог ясно выразится. Ваш код работает отлично. Это я о том, что после выполнения заливки, у меня перебрасывает на лист с последним залитым диапазоном. Про это и имею ввиду. Ремарка с моей стороны несущественная, её можно проигнорировать.
Страницы: 1
Наверх