Страницы: 1
RSS
Подсветка диапазона желтым цветом
 
Здраствуйте. Возник вопрос по макросу.
Есть макрос обводящий - обычными границами - область ячеек (диапазон с размерами 11х11), где единицы встречаются часто (шесть и более близкостоящих единиц).
Как изменить макрос, чтобы он - не просто обводил диапазон границами, а еще и менял цвет этого диапазона - на желтый ?

Пытался добавить кусок кода:
Код
    With .Interior(ii)
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
Но, что-то не срабатывает.
 
Для желтого цвета:  .Color = vbYellow
 
Этот код нарисует рамки вокруг диапазона [P15:R23], закрасит ячеки желтой заливкой и очистит внутренние линии, если они были:
Код
Sub Test()
  With Range("P15:R23")
    .BorderAround xlContinuous
    .Interior.Color = vbYellow
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
  End With
End Sub

Вместо xlNone можно записать xlContinuous, если нужны внутренние границыю
А чтобы оставить заливку ячеек с единицами, вместо .Interior.Color = vbYellow можно записать .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
Изменено: ZVI - 20.01.2018 10:23:47
 
ZVI, я не совсем понял - а добавлять-то этот код куда ?

Код обводки границами - выглядит так:
Код
Sub CommandButton2_Click()

    For n = 1 To 99 * m
        With Range(Cells(n, 1), Cells(n + m - 1, m))
            cn = 0
            For i = 1 To .Rows.count: For j = 1 To .Columns.count
                cn = cn + Abs(.Cells(i, j).Value = 1)
                If cn >= 6 Then
                    For ii = 7 To 10
                        With .Borders(ii)
                            .LineStyle = xlContinuous
                            .Weight = xlMedium
                            .ColorIndex = xlAutomatic
                       
                        End With
              
                    Next
                    
                    n = n + m - 1: Exit For
                End If
            Next j, i
        End With
    Next
End Sub
Ваш код - куда именно добавлять ?
 
Мой код относился к фрагменту, опубликованному Вами в сообщении  #1.
Опишите, пожалуйста, словами алгоритм выделения фрагментов.
 
Не разбираясь в алгоритме Ваш код может быть таким:
Код
Sub CommandButton2_Click()
  For n = 1 To 99 * m
    With Range(Cells(n, 1), Cells(n + m - 1, m))
      cn = 0
      For i = 1 To .Rows.Count
        For j = 1 To .Columns.Count
          cn = cn + Abs(.Cells(i, j).Value = 1)
          If cn >= 6 Then
            'Debug.Print .Address
            .BorderAround xlContinuous
            .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
            .BorderAround
            n = n + m - 1
            Exit For
          End If
        Next
      Next
    End With
  Next
End Sub
Изменено: ZVI - 20.01.2018 11:09:45
 
ZVI, описываю своими словами.

Макрос - просматривает условный квадрат 11x11 спускаясь постепенно вниз (по диапазону A:K)
Если найден квадрат, в котором - шесть или более единиц - то происходит выделение этого конкретного квадрата - границами.

А затем макрос в своем поиске - перемещается ниже с целью найти другой квадрат, в котором - шесть или более единиц.
И так далее, пока не дойдет до конца диапазона A:K (строка 1096).
 
Цитата
ZVI написал:
Мой код относился к фрагменту, опубликованному Вами в сообщении  #1.
Я этот фрагмент привел, потому что заметил в коде - такой кусок:
Код
                        With .Borders(ii)
                            .LineStyle = xlContinuous
                            .Weight = xlMedium
                            .ColorIndex = xlAutomatic
                        End With
И подумал, что если поставить рядышком похожий код :
Код
    With .Interior(ii)
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
То кроме выделения границами - еще и подсветка будет.
Но ничего подобного у меня не получилось.  
 
Посмотрите код в сообщении #6, я его немного подправил, убрав сетку (xlNone) для внутренних ячеек найденных фрагментах
Изменено: ZVI - 20.01.2018 11:13:12
 
Если нужна сетка внутри, то такой вариант:
Код
Sub CommandButton2_Click()
  For n = 1 To 99 * m
    With Range(Cells(n, 1), Cells(n + m - 1, m))
      cn = 0
      For i = 1 To .Rows.Count
        For j = 1 To .Columns.Count
          cn = cn + Abs(.Cells(i, j).Value = 1)
          If cn >= 6 Then
            Debug.Print .Address
            .BorderAround xlContinuous, xlMedium
            .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .BorderAround
            n = n + m - 1
            Exit For
          End If
        Next
      Next
    End With
  Next
End Sub
Изменено: ZVI - 20.01.2018 11:25:31
 
И для ускорения кода лучше использовать перебор значений массива, а не ячеек:
Код
Sub CommandButton2_Click()
  Dim a()
  For n = 1 To 99 * m
    With Range(Cells(n, 1), Cells(n + m - 1, m))
      cn = 0
      a() = .Value
      For i = 1 To m
        For j = 1 To m
          cn = cn + Abs(a(i, j) = 1)
          If cn >= 6 Then
            'Debug.Print .Address
            .BorderAround xlContinuous, xlMedium
            .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .BorderAround
            n = n + m - 1
            Exit For
          End If
        Next
      Next
    End With
  Next
End Sub
Изменено: ZVI - 20.01.2018 11:42:08
 
ZVI, ясно, спасибо за помощь.
 
Рад, что помог, всего доброго!
Страницы: 1
Наверх