Макрос по цветам

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Макрос по цветам (Макросы/Sub)

Макрос по цветам

eboryaeva

Дата: Вторник, 09.04.2019, 14:22 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Добрый день!

Есть файл в котором подрядчик цветами обозначает версии и распределяет их по месяцу.
Цель с помощью макроса в аналогичную таблицу справа вместо заливки ячейки. прописать название версии.

Как я понимаю, в этом случае необходимо использовать цикл по столбцу с версиями и по таблице где подрядчик показывает график.

Подскажите пожалуйста, можно ли как то сослаться с помощью макроса на цвет ячейки из одной таблицы, найти этот цвет в другой таблице и соотнеся данные внести их в третью таблицу?

Заранее спасибо)

К сообщению приложен файл: 3105929.xlsx (26.5 Kb)

Ответить

excelius

Дата: Вторник, 09.04.2019, 15:14 | Сообщение № 2

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Цвет ячейки [vba]

Код

Range.Interior.Color

[/vba]

Ответить

skais

Дата: Вторник, 09.04.2019, 15:18 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 236

Репутация: 29 ±

Замечаний: 20% ±

Excel 2010

Решение
[vba]

Код

Sub Button1_Click()
    Application.ScreenUpdating = False
    For Z = 6 To Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To 30
            For j = 2 To Cells(Rows.Count, "AP").End(xlUp).Row
                If Cells(Z, i).Interior.Pattern = xlPatternRectangularGradient Or Cells(Z, i).Interior.Pattern = xlPatternLinearGradient Then
                    If Cells(Z, i).Interior.Gradient.ColorStops(1).Color = Cells(j, "AK").Interior.Gradient.ColorStops(1).Color _
                    And Cells(Z, i).Interior.Gradient.ColorStops(2).Color = Cells(j, "AK").Interior.Gradient.ColorStops(2).Color Then
                        Cells(Z, i + 50) = Cells(j, "AP").Value
                        Exit For
                    End If
                End If
            Next
        Next
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл: 3105929.xlsm (38.5 Kb)

Сообщение отредактировал skais - Вторник, 09.04.2019, 15:22

Ответить

eboryaeva

Дата: Вторник, 09.04.2019, 15:46 | Сообщение № 4

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

skais, спасибо)

Как я понимаю, код работает только с градиентной заливкой, но подрядчик присылает иногда и простую заливку, и какую-то так сказать точечную. см вложение.
Подскажите пожалуйста, как обозначить такой тип заливки?

К сообщению приложен файл: Primer.xlsm (37.0 Kb)

Ответить

skais

Дата: Вторник, 09.04.2019, 16:40 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 236

Репутация: 29 ±

Замечаний: 20% ±

Excel 2010

[vba]

Код

Sub Button1_Click()
'.Range("BA6:CE59").ClearContents
    Application.ScreenUpdating = False
    For Z = 6 To Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To 30
            For j = 2 To Cells(Rows.Count, "AP").End(xlUp).Row
                If Cells(Z, i).Interior.Pattern = Cells(j, "AK").Interior.Pattern Then
                    If (Cells(Z, i).Interior.Pattern = xlPatternRectangularGradient Or Cells(Z, i).Interior.Pattern = xlPatternLinearGradient) Then
                        If Cells(Z, i).Interior.Gradient.ColorStops(1).Color = Cells(j, "AK").Interior.Gradient.ColorStops(1).Color _
                        And Cells(Z, i).Interior.Gradient.ColorStops(2).Color = Cells(j, "AK").Interior.Gradient.ColorStops(2).Color Then
                            Cells(Z, i + 50) = Cells(j, "AP").Value
                            Exit For
                        End If
                    ElseIf Cells(Z, i).Interior.Color = Cells(j, "AK").Interior.Color And Cells(Z, i).Font.Color = Cells(j, "AK").Font.Color Then
                        Cells(Z, i + 50) = Cells(j, "AP").Value
                        Exit For
                    End If
                End If
            Next
        Next
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл: Primer-2-.xlsm (39.8 Kb)

Сообщение отредактировал skais - Вторник, 09.04.2019, 16:47

Ответить

eboryaeva

Дата: Понедельник, 15.04.2019, 16:27 | Сообщение № 6

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

skais, Большое спасибо за помощь, макрос работает просто прекрасно.

Подскажите пожалуйста, сможет ли он работать при условном форматировании ячеек по цветам, а не при ручном?

Ответить

bmv98rus

Дата: Понедельник, 15.04.2019, 17:34 | Сообщение № 7

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4115

Репутация: 769 ±

Замечаний: 0% ±

Excel 2013/2016

Цитата eboryaeva, 15.04.2019 в 16:27, в сообщении № 6 ()

сможет ли он работать при условном форматировании ячеек по цветам

этот - нет, но коррекция вроде не большая , в случае если Excel 2010 и новее.

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

Ответить

eboryaeva

Дата: Понедельник, 15.04.2019, 18:41 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

bmv98rus, Подскажите пожалуйста. как можно считать формат ячейки при условном форматировании с помощью макроса? А то в интернете информации о том как создать уловное форматирование с помощью макроса полно. а о том как его считать найти не могу...

Ответить

bmv98rus

Дата: Понедельник, 15.04.2019, 19:20 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4115

Репутация: 769 ±

Замечаний: 0% ±

Excel 2013/2016

Range.DispalyFormat - это то что "видят глаза".

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

Ответить

Макрос по цветам (Макросы/Sub)

Страница 1 из 1
1