Страницы: 1
RSS
Как скопировать диапазон с условным форматированием на новый лист вместе с установленным окрашиванием ячеек
 
Доброго времени суток. Подскажите, пожалуйста, как вместе с текстовой информацией из указанного диапазона скопировать еще и ФОРМАТИРОВАНИЕ (цвет ячеек ) ?

Файл-пример в приложении.

Проблема в том, что копируется все, кроме цвета ячеек. Точнее, он копируется, но криво. Цвет ячеек задается условным форматированием и, при копировании-вставке диапазона с условным форматированием в новое место ( лист, книга ), формулы условного форматирования сбиваются и цвета определяются некорректно.

Спасибо.
Улыбнись.
 
дак пропишите в макросе чтоб копировалось на в столбец А а не в G и все будет работать так как у вас в УФ закреплен столбец $
Лень двигатель прогресса, доказано!!!
 
Сергей, суть в том, что копирование происходит в другой столбец.
Спасибо за наводку! Понял, что дело в то, что в условном форматировании закреплен столбец $
Спасибо!
Улыбнись.
 
Сергей, Я попробовал убрать в УФ $ и выделение стало не таким, каким оно было задумано. Выделяются только ячейки столбца, а не ячейки диапазона (несколько ячеек разных столбцов, но одной строки)

Есть способы решения этого дела?
Улыбнись.
 
falmrom,  посмотрите здесь
 
Anchoret, спасибо!
Улыбнись.
 
Код
Sub Макрос2()
    Range("A4:D9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Лист2").Select
    Range("G1").Select
    ActiveSheet.Paste
    For Each c In [g1].Resize(6, 4)
      c.Interior.Color = Worksheets(1).Range(c.Offset(3, -6).Address).DisplayFormat.Interior.Color
    Next
    Range("G1").Select
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Anchoret, Добрый день. Подскажите, пожалуйста, что изменить в коде под то, чтобы можно было копировать УФ выбранного диапазона из одной книги в другую. Спасибо!
Код
Sub CondFlash()
Dim aa As Range, arr(), a&, b&, c&, dd(), cc()
Set aa = [D4].CurrentRegion
ReDim arr(1 To aa.Rows.Count, 1 To aa.Columns.Count)
For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If aa(a, b).FormatConditions.Count > 0 Then
      ReDim dd(1 To aa(a, b).FormatConditions.Count): ReDim cc(1 To 11)
      For c = 1 To UBound(dd)
        With aa(a, b).FormatConditions.Item(c)
          cc(1) = .Type: cc(2) = .Operator
          cc(3) = Replace(.Formula1, "=", "")
          cc(4) = Replace(.Formula2, "=", ""): cc(5) = .Priority
          cc(7) = .Interior.Color: cc(8) = .Font.Color
          cc(9) = .Font.Bold: cc(10) = .Font.Italic: cc(11) = .StopIfTrue
          dd(c) = cc
        End With
      Next
      arr(a, b) = dd
    End If
  Next
Next
aa.FormatConditions.Delete
'-----------
MsgBox "FormatConditions store to Array and Deleted. Ready for Print!"

'-----------
Application.ScreenUpdating = False
For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If IsArray(arr(a, b)) Then
      For c = 1 To UBound(arr(a, b))
        aa(a, b).FormatConditions.Add Type:=arr(a, b)(c)(1), Operator:=arr(a, b)(c)(2), _
                 Formula1:=arr(a, b)(c)(3), Formula2:=arr(a, b)(c)(4)
        With aa(a, b).FormatConditions(c)
          .Priority = arr(a, b)(c)(5): .Interior.Color = arr(a, b)(c)(7)
          .Font.Color = arr(a, b)(c)(8): .Font.Bold = arr(a, b)(c)(9):
          .Font.Italic = arr(a, b)(c)(10): .StopIfTrue = arr(a, b)(c)(11)
        End With
      Next
    End If
  Next
Next
Application.ScreenUpdating = True
MsgBox "FormatConditions restored!"
End Sub
Улыбнись.
 
Anchoret, мой код:

Код
        Windows(Эта_книга).Activate                 ' ОТКРЫТЬ КНИГУ, КОТОРАЯ ГЕНЕРИРУЮЕТ ПОДСЧЕТЫ
        
        
'================================ВЫДЕЛЕНИЕ И КОПИРОВАНИЕ НЕОБХОДИМОГО ДИАПАЗОНА

        Range("A" & Строка_по_факту - 1 & ":D" & итого).Select ' ВЫДЕЛИТЬ ТАБЛИЦУ
        Range("A" & Строка_по_факту - 1 & ":D" & итого).Select ' ВЫДЕЛИТЬ ТАБЛИЦУ
        Selection.Copy  'Скопирвать таблицу



        Dim aa As Range, arr(), a&, b&, c&, dd(), cc()
Set aa = [D4].CurrentRegion
ReDim arr(1 To aa.Rows.Count, 1 To aa.Columns.Count)
For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If aa(a, b).FormatConditions.Count > 0 Then
      ReDim dd(1 To aa(a, b).FormatConditions.Count): ReDim cc(1 To 11)
      For c = 1 To UBound(dd)
        With aa(a, b).FormatConditions.Item(c)
          cc(1) = .Type: cc(2) = .Operator
          cc(3) = Replace(.Formula1, "=", "")
          cc(4) = Replace(.Formula2, "=", ""): cc(5) = .Priority
          cc(7) = .Interior.Color: cc(8) = .Font.Color
          cc(9) = .Font.Bold: cc(10) = .Font.Italic: cc(11) = .StopIfTrue
          dd(c) = cc
        End With
      Next
      arr(a, b) = dd
    End If
  Next
Next


        
        







        '+++++++++++==========ВСТАВИТЬ СКОПИР. ТАБЛИЦУ ИЗ ГЕНЕР. ФАЙЛА В КНИГУ С ОТЧЕТАМИ===================
        Windows(НазваниеФайлаОтчета).Activate       ' АКТИВИРОВАТЬ КНИГУ С ОТЧЕТАМИ
        Cells(ЯчейкаТабл111222, ЯчейкаТабл111333).Select
        ActiveSheet.Paste
        '+++++++++++========================================================================================
        

For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If IsArray(arr(a, b)) Then
      For c = 1 To UBound(arr(a, b))
        aa(a, b).FormatConditions.Add Type:=arr(a, b)(c)(1), Operator:=arr(a, b)(c)(2), _
                 Formula1:=arr(a, b)(c)(3), Formula2:=arr(a, b)(c)(4)
        With aa(a, b).FormatConditions(c)
          .Priority = arr(a, b)(c)(5): .Interior.Color = arr(a, b)(c)(7)
          .Font.Color = arr(a, b)(c)(8): .Font.Bold = arr(a, b)(c)(9):
          .Font.Italic = arr(a, b)(c)(10): .StopIfTrue = arr(a, b)(c)(11)
        End With
      Next
    End If
  Next
Next
Изменено: falmrom - 06.03.2019 11:36:20
Улыбнись.
 
РЕШЕНО!
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=76216
Улыбнись.
Страницы: 1
Наверх