Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Замена в ячейках УФ - на реальные цвета - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена в ячейках УФ - на реальные цвета (Макросы/Sub)
Замена в ячейках УФ - на реальные цвета
RipVanWinkel Дата: Пятница, 04.05.2018, 18:37 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
У меня есть макрос, который заменяет цвета условного формата - на реальные цвета.
Надо выделить область ячеек и нажать на кнопку.
Однако макрос - не работает.
Дело в том, что условных цветов в некоторых ячейках - несколько, а макрос выбирает - не тот цвет, который стоит в ячейке сейчас, а другой УФ - и присваивает ему реальный цвет.

Как изменить этот макрос, чтобы он убирая УФ - присваивал реальные цвета тому УФ, которое действует в ячейках на текущий момент ?
К сообщению приложен файл: 111.xls (51.5 Kb)
 
Ответить
СообщениеДобрый день.
У меня есть макрос, который заменяет цвета условного формата - на реальные цвета.
Надо выделить область ячеек и нажать на кнопку.
Однако макрос - не работает.
Дело в том, что условных цветов в некоторых ячейках - несколько, а макрос выбирает - не тот цвет, который стоит в ячейке сейчас, а другой УФ - и присваивает ему реальный цвет.

Как изменить этот макрос, чтобы он убирая УФ - присваивал реальные цвета тому УФ, которое действует в ячейках на текущий момент ?
Автор - RipVanWinkel
Дата добавления - 04.05.2018 в 18:37
bmv98rus Дата: Пятница, 04.05.2018, 22:05 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4106
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
результирующий формат будет в .DisplayFormat , что позволит не перебирать все условия.

Замечательный Временно просто медведь , процентов на 20.
 
Ответить
Сообщениерезультирующий формат будет в .DisplayFormat , что позволит не перебирать все условия.
Автор - bmv98rus
Дата добавления - 04.05.2018 в 22:05
RipVanWinkel Дата: Пятница, 04.05.2018, 23:35 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
bmv98rus, подскажите - куда именно в имеющийся макрос - добавить текст .DisplayFormat ?
 
Ответить
Сообщениеbmv98rus, подскажите - куда именно в имеющийся макрос - добавить текст .DisplayFormat ?
Автор - RipVanWinkel
Дата добавления - 04.05.2018 в 23:35
bmv98rus Дата: Суббота, 05.05.2018, 08:03 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4106
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
не все так просто, в коде много переделывать
Set FC = cell.FormatConditions(1) заменится на with cell.DisplayFormat,
а далее все переписать для копирования формата до cell.FormatConditions.Delete
При этом хорошоб копировать не только фон, но и формат текста.

Замечательный Временно просто медведь , процентов на 20.
 
Ответить
Сообщениене все так просто, в коде много переделывать
Set FC = cell.FormatConditions(1) заменится на with cell.DisplayFormat,
а далее все переписать для копирования формата до cell.FormatConditions.Delete
При этом хорошоб копировать не только фон, но и формат текста.
Автор - bmv98rus
Дата добавления - 05.05.2018 в 08:03
RAN Дата: Суббота, 05.05.2018, 10:54 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Все еще сложнее, чем
Цитата bmv98rus, 05.05.2018 в 08:03, в сообщении № 4 ()
не все так просто

Заинтриговало, может сделаю.

Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеВсе еще сложнее, чем
Цитата bmv98rus, 05.05.2018 в 08:03, в сообщении № 4 ()
не все так просто

Заинтриговало, может сделаю.
Автор - RAN
Дата добавления - 05.05.2018 в 10:54
bmv98rus Дата: Суббота, 05.05.2018, 14:24 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4106
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
RAN, ну можно пойти по неправедному пути, вычислить условия, определить старшинство уф ... и взять формат нужного. Но это не так интересно. Да и в котов я верю :-)

Замечательный Временно просто медведь , процентов на 20.

Сообщение отредактировал bmv98rus - Воскресенье, 06.05.2018, 08:31
 
Ответить
СообщениеRAN, ну можно пойти по неправедному пути, вычислить условия, определить старшинство уф ... и взять формат нужного. Но это не так интересно. Да и в котов я верю :-)
Автор - bmv98rus
Дата добавления - 05.05.2018 в 14:24
RAN Дата: Понедельник, 07.05.2018, 09:55 | Сообщение № 7
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Формат "Число", созданный УФ, не обрабатывается.
[vba]
Код
'---------------------------------------------------------------------------------------
' Procedure : Format_Display
' DateTime  : 07.05.2018
' Author    : RAN (ran.xls@ya.ru)
' Purpose   : Замена форматов Условного Форматирования на реальные
'---------------------------------------------------------------------------------------
'
Sub Format_Display()
    Dim cell As Range, rRange As Range
    Dim dfBorders As Object, dfFont As Object, dfInterior As Object
    Dim i&

    If TypeName(Selection) <> "Range" Then MsgBox "Выделенная область не является диапазоном ячеек", _
       vbCritical, "Неверные данные": Exit Sub
    If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", _
              vbExclamation + vbYesNo) <> vbYes Then Exit Sub
    Set rRange = Intersect(Selection, Selection.Parent.UsedRange)
    Application.ScreenUpdating = False
    For Each cell In rRange
        If cell.FormatConditions.Count Then

            '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%
            Set dfBorders = cell.DisplayFormat.Borders
            With cell.Borders
                For i = 1 To 4
                    .Item(i).LineStyle = dfBorders.Item(i).LineStyle
                    .Item(i).ColorIndex = dfBorders.Item(i).ColorIndex
                Next
            End With
            '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%

            '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
            Set dfFont = cell.DisplayFormat.Font
            With cell.Font
                .Color = dfFont.Color
                .Bold = dfFont.Bold
                .Italic = dfFont.Italic
                .Strikethrough = dfFont.Strikethrough
                .Underline = dfFont.Underline
            End With
            '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%

            '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
            Set dfInterior = cell.DisplayFormat.Interior
            With cell.Interior
                If Not dfInterior.Gradient Is Nothing Then
                    .Pattern = dfInterior.Pattern
                    Do While .Gradient.ColorStops.Count < dfInterior.Gradient.ColorStops.Count
                        .Gradient.ColorStops.Add (0)
                        DoEvents
                    Loop
                    If .Pattern = 4001 Then
                        .Gradient.RectangleLeft = dfInterior.Gradient.RectangleLeft
                        .Gradient.RectangleRight = dfInterior.Gradient.RectangleRight
                        .Gradient.RectangleTop = dfInterior.Gradient.RectangleTop
                        .Gradient.RectangleBottom = dfInterior.Gradient.RectangleBottom
                    Else
                        .Gradient.Degree = dfInterior.Gradient.Degree
                    End If
                    For i = 1 To dfInterior.Gradient.ColorStops.Count
                        .Gradient.ColorStops(i).Color = dfInterior.Gradient.ColorStops(i).Color
                        .Gradient.ColorStops(i).Position = dfInterior.Gradient.ColorStops(i).Position
                        If dfInterior.Gradient.ColorStops(i).ThemeColor Then _
                           .Gradient.ColorStops(i).ThemeColor = dfInterior.Gradient.ColorStops(i).ThemeColor
                        .Gradient.ColorStops(i).TintAndShade = dfInterior.Gradient.ColorStops(i).TintAndShade
                    Next
                Else
                    .Pattern = dfInterior.Pattern
                    If .Pattern <> xlPatternNone Then
                        .Color = dfInterior.Color
                        .PatternColor = dfInterior.PatternColor
                    End If
                End If
            End With
            '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
        End If
    Next
    rRange.FormatConditions.Delete
    Application.ScreenUpdating = True

End Sub
[/vba]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Понедельник, 07.05.2018, 09:56
 
Ответить
СообщениеФормат "Число", созданный УФ, не обрабатывается.
[vba]
Код
'---------------------------------------------------------------------------------------
' Procedure : Format_Display
' DateTime  : 07.05.2018
' Author    : RAN (ran.xls@ya.ru)
' Purpose   : Замена форматов Условного Форматирования на реальные
'---------------------------------------------------------------------------------------
'
Sub Format_Display()
    Dim cell As Range, rRange As Range
    Dim dfBorders As Object, dfFont As Object, dfInterior As Object
    Dim i&

    If TypeName(Selection) <> "Range" Then MsgBox "Выделенная область не является диапазоном ячеек", _
       vbCritical, "Неверные данные": Exit Sub
    If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", _
              vbExclamation + vbYesNo) <> vbYes Then Exit Sub
    Set rRange = Intersect(Selection, Selection.Parent.UsedRange)
    Application.ScreenUpdating = False
    For Each cell In rRange
        If cell.FormatConditions.Count Then

            '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%
            Set dfBorders = cell.DisplayFormat.Borders
            With cell.Borders
                For i = 1 To 4
                    .Item(i).LineStyle = dfBorders.Item(i).LineStyle
                    .Item(i).ColorIndex = dfBorders.Item(i).ColorIndex
                Next
            End With
            '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%

            '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
            Set dfFont = cell.DisplayFormat.Font
            With cell.Font
                .Color = dfFont.Color
                .Bold = dfFont.Bold
                .Italic = dfFont.Italic
                .Strikethrough = dfFont.Strikethrough
                .Underline = dfFont.Underline
            End With
            '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%

            '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
            Set dfInterior = cell.DisplayFormat.Interior
            With cell.Interior
                If Not dfInterior.Gradient Is Nothing Then
                    .Pattern = dfInterior.Pattern
                    Do While .Gradient.ColorStops.Count < dfInterior.Gradient.ColorStops.Count
                        .Gradient.ColorStops.Add (0)
                        DoEvents
                    Loop
                    If .Pattern = 4001 Then
                        .Gradient.RectangleLeft = dfInterior.Gradient.RectangleLeft
                        .Gradient.RectangleRight = dfInterior.Gradient.RectangleRight
                        .Gradient.RectangleTop = dfInterior.Gradient.RectangleTop
                        .Gradient.RectangleBottom = dfInterior.Gradient.RectangleBottom
                    Else
                        .Gradient.Degree = dfInterior.Gradient.Degree
                    End If
                    For i = 1 To dfInterior.Gradient.ColorStops.Count
                        .Gradient.ColorStops(i).Color = dfInterior.Gradient.ColorStops(i).Color
                        .Gradient.ColorStops(i).Position = dfInterior.Gradient.ColorStops(i).Position
                        If dfInterior.Gradient.ColorStops(i).ThemeColor Then _
                           .Gradient.ColorStops(i).ThemeColor = dfInterior.Gradient.ColorStops(i).ThemeColor
                        .Gradient.ColorStops(i).TintAndShade = dfInterior.Gradient.ColorStops(i).TintAndShade
                    Next
                Else
                    .Pattern = dfInterior.Pattern
                    If .Pattern <> xlPatternNone Then
                        .Color = dfInterior.Color
                        .PatternColor = dfInterior.PatternColor
                    End If
                End If
            End With
            '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
        End If
    Next
    rRange.FormatConditions.Delete
    Application.ScreenUpdating = True

End Sub
[/vba]
Автор - RAN
Дата добавления - 07.05.2018 в 09:55
bmv98rus Дата: Понедельник, 07.05.2018, 13:13 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4106
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
Off.
RAN, Я верил и не напрасно. :-)

Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеOff.
RAN, Я верил и не напрасно. :-)
Автор - bmv98rus
Дата добавления - 07.05.2018 в 13:13
RipVanWinkel Дата: Понедельник, 07.05.2018, 19:11 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
RAN, спасибо.
Работает макрос.
 
Ответить
СообщениеRAN, спасибо.
Работает макрос.
Автор - RipVanWinkel
Дата добавления - 07.05.2018 в 19:11
RAN Дата: Понедельник, 07.05.2018, 19:15 | Сообщение № 10
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Цитата bmv98rus, 05.05.2018 в 14:24, в сообщении № 6 ()
можно пойти по неправедному пути, вычислить условия, определить старшинство уф

Цитата bmv98rus, 05.05.2018 в 14:24, в сообщении № 6 ()
Но это не так интересно

Это, как раз, самое интересное. И самое не простое.

Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
Цитата bmv98rus, 05.05.2018 в 14:24, в сообщении № 6 ()
можно пойти по неправедному пути, вычислить условия, определить старшинство уф

Цитата bmv98rus, 05.05.2018 в 14:24, в сообщении № 6 ()
Но это не так интересно

Это, как раз, самое интересное. И самое не простое.
Автор - RAN
Дата добавления - 07.05.2018 в 19:15
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена в ячейках УФ - на реальные цвета (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!