Отображение границы раздела двух цветовых сред. - Мир MS Excel

Регистрация

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

= Мир MS Excel/Отображение границы раздела двух цветовых сред. - Мир MS Excel

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

Отображение границы раздела двух цветовых сред. (Формулы/Formulas)

Отображение границы раздела двух цветовых сред.

Дата: Среда, 04.01.2017, 19:40 | Сообщение № 1

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

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

Сообщений: 163

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

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

Excel 2013

День добрый,уважаемые программисты.
Помогите с решением проблемы.

На листе экселя - находится диапазон ячеек.
В этом диапазоне находятся ячейки разного цвета.
В месте соприкосновения ячеек с разной окраской - нужно, чтобы на границе возникала линия.
То есть линия границы ячейки.
Как это можно сделать макросом?

К сообщению приложен файл: File.xls (27.5 Kb)

Сообщение отредактировал rotten41 - Четверг, 05.01.2017, 07:00

Ответить

Дата: Среда, 04.01.2017, 21:29 | Сообщение № 2

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

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

Сообщений: 193

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

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

2016

рисовать можно с помощью УФ по значению ячейки, плюс условия на соответствие значенениям соседним ячейкам.
и без танцев

Сообщение отредактировал dude - Среда, 04.01.2017, 21:30

Ответить

Дата: Четверг, 05.01.2017, 06:57 | Сообщение № 3

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

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

Сообщений: 163

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

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

Excel 2013

dude, это не подходит.
Цветов очень много. Потом ячейки - должны быть пустыми, там должен быть только цвет.
Я имел ввиду макрос.

Ответить

Дата: Четверг, 05.01.2017, 08:32 | Сообщение № 4

Группа: Заблокированные

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

Сообщений: 3442

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

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

2010, 2013, 2016 RUS / ENG

rotten41,

Цитата

Цветов очень много

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

Ответить

Дата: Четверг, 05.01.2017, 09:29 | Сообщение № 5

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

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

Сообщений: 163

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

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

Excel 2013

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

Как происходит окрашивание. Мне кажется, что - надо только пройтись по окрашенному полю и проставить границы.

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

Сообщение отредактировал rotten41 - Четверг, 05.01.2017, 09:38

Ответить

Дата: Четверг, 05.01.2017, 09:47 | Сообщение № 6

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

Ранг: Экселист

Сообщений: 9130

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

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

Excel 2010

выделяем, запускаем, ждем часа 3-4 (или пару минут, как повезет)
[vba]

Код

Sub Line_18()
Application.ScreenUpdating = 0
'-------------------------------------------------------------
    For Each e In Selection
    If e.Interior.Color <> e.Offset(0, 1).Interior.Color And e.Interior.Color <> 16777215 And e.Offset(0, 1).Interior.Color <> 16777215 Then
    With e.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    End If
    Next
'-------------------------------------------------------------
    For Each e In Selection
    If e.Interior.Color <> e.Offset(1, 0).Interior.Color And e.Interior.Color <> 16777215 And e.Offset(1, 0).Interior.Color <> 16777215 Then
    With e.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    End If
    Next
End Sub

[/vba]

ЮMoney 41001841029809

Ответить

Дата: Четверг, 05.01.2017, 09:53 | Сообщение № 7

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

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

Сообщений: 4147

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

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

Excel 2013/2016

[vba]

Код

Sub Border()
Application.ScreenUpdating = false
    myEdge = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    MyRow = Array(0, -1, 1, 0)
    myColumn = Array(-1, 0, 0, 1)

    For Each Mycell In Selection
    Mycell.Activate
    For i = 0 To 3 ' можно 0 то 1
    If Mycell.Offset(MyRow(i), myColumn(i)).Interior.Color <> Mycell.Interior.Color And _
        Mycell.Interior.Color <> 16777215 And _
        Mycell.Offset(MyRow(i), myColumn(i)).Interior.Color <> 16777215 Then

        With Mycell.Borders(myEdge(i))
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    End If
    Next i
    Next
Application.ScreenUpdating = true
End Sub

[/vba]

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

Сообщение отредактировал bmv98rus - Четверг, 05.01.2017, 09:55

Ответить

Дата: Четверг, 05.01.2017, 10:02 | Сообщение № 8

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

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

Сообщений: 163

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

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

Excel 2013

Nic70y, код работает очень быстро.
Но никак не реагирует на белый цвет.
Белый цвет - это ведь тоже цвет.

Ответить

Дата: Четверг, 05.01.2017, 10:04 | Сообщение № 9

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

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

Сообщений: 163

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

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

Excel 2013

bmv98rus, код работает медленнее, зато очень интересно на него смотреть - как он постепенно отрисовывает границы.

Та же проблема - не реагирует на белый цвет (имеется ввиду белый цвет заливки ячеек).

Ответить

Дата: Четверг, 05.01.2017, 10:06 | Сообщение № 10

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

Ранг: Экселист

Сообщений: 9130

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

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

Excel 2010

уберите это:
[vba]

Код

And e.Interior.Color <> 16777215 And e.Offset(0, 1).Interior.Color <> 16777215

[/vba]
[vba]

Код

And e.Interior.Color <> 16777215 And e.Offset(1, 0).Interior.Color <> 16777215

[/vba]

ЮMoney 41001841029809

Ответить

Дата: Четверг, 05.01.2017, 10:17 | Сообщение № 11

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

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

Сообщений: 163

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

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

Excel 2013

Nic70y, теперь все заработало как надо.
Большое спасибо.

Ответить

Дата: Четверг, 05.01.2017, 10:49 | Сообщение № 12

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

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

Сообщений: 4147

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

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

Excel 2013/2016

rotten41,

черт, :-) не убрал строку :-) Mycell.Activate , сперва в масиив не туда единичку поставил, а так отлаживать проще. Белый - все как в задании :-). раз два человека одинаково поняли, значит так было написано :-)

Яб еще область обработки привел к размерам используемой в пределах выделенного. тогда совсем будет быстро.

[vba]

Код

Sub Border()
    Debug.Print Now
    Application.ScreenUpdating = False
    myEdge = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    MyRow = Array(0, -1, 1, 0)
    myColumn = Array(-1, 0, 0, 1)
    If Selection.Row > ActiveSheet.UsedRange.Row Then
        WorkRow1 = Selection.Row
    Else
        WorkRow1 = ActiveSheet.UsedRange.Row
    End If
    If Selection.Row + Selection.Rows.Count < ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count Then
        WorkRow2 = Selection.Row + Selection.Rows.Count
    Else
        WorkRow2 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    End If
    If Selection.Column > ActiveSheet.UsedRange.Column Then
        WorkColumn1 = Selection.Column
    Else
        WorkColumn1 = ActiveSheet.UsedRange.Column
    End If
    If Selection.Column + Selection.Columns.Count < ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count Then
        WorkColumn2 = Selection.Columns.Count + Selection.Columns.Count - 1
    Else
        WorkColumn2 = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
    End If

    For Each mycell In ActiveSheet.Range(Cells(WorkRow1, WorkColumn1), Cells(WorkRow2, WorkColumn2))
        For i = 2 To 3
            If mycell.Offset(MyRow(i), myColumn(i)).Interior.Color <> mycell.Interior.Color Then
                With mycell.Borders(myEdge(i))
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
        End If
        Next i
    Next
    Application.ScreenUpdating = True
    Debug.Print Now
End Sub

[/vba]

rotten41,

черт, :-) не убрал строку :-) Mycell.Activate , сперва в масиив не туда единичку поставил, а так отлаживать проще. Белый - все как в задании :-). раз два человека одинаково поняли, значит так было написано :-)

Яб еще область обработки привел к размерам используемой в пределах выделенного. тогда совсем будет быстро.

[vba]

Код

Sub Border()
    Debug.Print Now
    Application.ScreenUpdating = False
    myEdge = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    MyRow = Array(0, -1, 1, 0)
    myColumn = Array(-1, 0, 0, 1)
    If Selection.Row > ActiveSheet.UsedRange.Row Then
        WorkRow1 = Selection.Row
    Else
        WorkRow1 = ActiveSheet.UsedRange.Row
    End If
    If Selection.Row + Selection.Rows.Count < ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count Then
        WorkRow2 = Selection.Row + Selection.Rows.Count
    Else
        WorkRow2 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    End If
    If Selection.Column > ActiveSheet.UsedRange.Column Then
        WorkColumn1 = Selection.Column
    Else
        WorkColumn1 = ActiveSheet.UsedRange.Column
    End If
    If Selection.Column + Selection.Columns.Count < ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count Then
        WorkColumn2 = Selection.Columns.Count + Selection.Columns.Count - 1
    Else
        WorkColumn2 = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
    End If

    For Each mycell In ActiveSheet.Range(Cells(WorkRow1, WorkColumn1), Cells(WorkRow2, WorkColumn2))
        For i = 2 To 3
            If mycell.Offset(MyRow(i), myColumn(i)).Interior.Color <> mycell.Interior.Color Then
                With mycell.Borders(myEdge(i))
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
        End If
        Next i
    Next
    Application.ScreenUpdating = True
    Debug.Print Now
End Sub

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

Сообщение отредактировал bmv98rus - Четверг, 05.01.2017, 11:27

Ответить

Сообщениеrotten41,

черт, :-) не убрал строку :-) Mycell.Activate , сперва в масиив не туда единичку поставил, а так отлаживать проще. Белый - все как в задании :-). раз два человека одинаково поняли, значит так было написано :-)

Яб еще область обработки привел к размерам используемой в пределах выделенного. тогда совсем будет быстро.

[vba]

Код

Sub Border()
    Debug.Print Now
    Application.ScreenUpdating = False
    myEdge = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    MyRow = Array(0, -1, 1, 0)
    myColumn = Array(-1, 0, 0, 1)
    If Selection.Row > ActiveSheet.UsedRange.Row Then
        WorkRow1 = Selection.Row
    Else
        WorkRow1 = ActiveSheet.UsedRange.Row
    End If
    If Selection.Row + Selection.Rows.Count < ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count Then
        WorkRow2 = Selection.Row + Selection.Rows.Count
    Else
        WorkRow2 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    End If
    If Selection.Column > ActiveSheet.UsedRange.Column Then
        WorkColumn1 = Selection.Column
    Else
        WorkColumn1 = ActiveSheet.UsedRange.Column
    End If
    If Selection.Column + Selection.Columns.Count < ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count Then
        WorkColumn2 = Selection.Columns.Count + Selection.Columns.Count - 1
    Else
        WorkColumn2 = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
    End If

    For Each mycell In ActiveSheet.Range(Cells(WorkRow1, WorkColumn1), Cells(WorkRow2, WorkColumn2))
        For i = 2 To 3
            If mycell.Offset(MyRow(i), myColumn(i)).Interior.Color <> mycell.Interior.Color Then
                With mycell.Borders(myEdge(i))
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
        End If
        Next i
    Next
    Application.ScreenUpdating = True
    Debug.Print Now
End Sub

[/vba]

Автор - bmv98rus
Дата добавления - 05.01.2017 в 10:49

Дата: Четверг, 05.01.2017, 10:51 | Сообщение № 13

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

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

Сообщений: 163

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

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

Excel 2013

bmv98rus, ясно

Ответить

Дата: Четверг, 05.01.2017, 11:54 | Сообщение № 14

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

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

Сообщений: 4147

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

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

Excel 2013/2016

rotten41,

Последний вариант выше - ну если не мгновенен, то быстр.

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

Ответить

Дата: Четверг, 05.01.2017, 14:19 | Сообщение № 15

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

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

Сообщений: 163

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

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

Excel 2013

bmv98rus, да я не спорю - хороший код.

Ответить

Дата: Четверг, 05.01.2017, 15:51 | Сообщение № 16

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

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

Сообщений: 4147

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

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

Excel 2013/2016

rotten41,

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

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

Ответить

Отображение границы раздела двух цветовых сред. (Формулы/Formulas)

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

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