Function КЦ(диапазон As Range, цвет As Range) As Single Dim c As Range For Each c In диапазон If c.Interior.ColorIndex = цвет.Interior.ColorIndex Then КЦ = КЦ + 1 End If Next End Function
[/vba] Которая подсчитывает количество ячеек закрашенных определнным цветом. Но проблема в том, что 10 обьедененных ячеек закрашенных определенным цветом она считает как 10. Как её заставить считать обьедененные ячейки как одну?
Заранее спасибо.
Добрый день. Есть функция [vba]
Код
Function КЦ(диапазон As Range, цвет As Range) As Single Dim c As Range For Each c In диапазон If c.Interior.ColorIndex = цвет.Interior.ColorIndex Then КЦ = КЦ + 1 End If Next End Function
[/vba] Которая подсчитывает количество ячеек закрашенных определнным цветом. Но проблема в том, что 10 обьедененных ячеек закрашенных определенным цветом она считает как 10. Как её заставить считать обьедененные ячейки как одну?
SkyPro, да, макрос неправильно работал. Новый макрос:
[vba]
Код
Function КЦ(диапазон As Range, цвет As Range) As Long
Application.Volatile True
'Удобнее писать код с подключённой библиотекой. 'Библиотеку можно так подключить: 'Tools - References... - Microsoft Scripting Runtime Dim dicMy As Object 'Scripting.Dictionary Dim c As Range
'Создаём словарь, в который будем записывать те ячейки 'или объединённые области, который мы уже подсчитали. Set dicMy = CreateObject(Class:="Scripting.Dictionary")
For Each c In диапазон
'Смотрим, есть ли в словаре элемент, имя которого - это адрес 'уже подсчитанной ячейки или объединённой области ячеек. 'Если нет элемента с таким именем. If dicMy.Exists(Key:=c.MergeArea.Address) = False Then
'Смотрим цвет ячейки. 'Если у ячейки нужный цвет. If c.Interior.ColorIndex = цвет.Interior.ColorIndex Then
'Подсчитываем. КЦ = КЦ + 1
'Создаём в словаре элемент с именем, которое 'представляет собой адрес объединённой области. 'Key - это имя элемента в словаре. 'Item - это данные, которые содержатся в элементе. 'Нам данные в данном случае не нужны, но 'синтаксис команды "Add" требует, 'чтобы мы указали параметр "Item". dicMy.Add Key:=c.MergeArea.Address, Item:=""
End If
End If
Next c
End Function
[/vba]
SkyPro, да, макрос неправильно работал. Новый макрос:
[vba]
Код
Function КЦ(диапазон As Range, цвет As Range) As Long
Application.Volatile True
'Удобнее писать код с подключённой библиотекой. 'Библиотеку можно так подключить: 'Tools - References... - Microsoft Scripting Runtime Dim dicMy As Object 'Scripting.Dictionary Dim c As Range
'Создаём словарь, в который будем записывать те ячейки 'или объединённые области, который мы уже подсчитали. Set dicMy = CreateObject(Class:="Scripting.Dictionary")
For Each c In диапазон
'Смотрим, есть ли в словаре элемент, имя которого - это адрес 'уже подсчитанной ячейки или объединённой области ячеек. 'Если нет элемента с таким именем. If dicMy.Exists(Key:=c.MergeArea.Address) = False Then
'Смотрим цвет ячейки. 'Если у ячейки нужный цвет. If c.Interior.ColorIndex = цвет.Interior.ColorIndex Then
'Подсчитываем. КЦ = КЦ + 1
'Создаём в словаре элемент с именем, которое 'представляет собой адрес объединённой области. 'Key - это имя элемента в словаре. 'Item - это данные, которые содержатся в элементе. 'Нам данные в данном случае не нужны, но 'синтаксис команды "Add" требует, 'чтобы мы указали параметр "Item". dicMy.Add Key:=c.MergeArea.Address, Item:=""
Function КЦВ(диапазон As Range, цвет As Range) Application.Volatile True Dim ячейки As Range With CreateObject("Scripting.Dictionary") For Each ячейки In диапазон If ячейки.MergeCells And ячейки.Interior.ColorIndex = цвет.Interior.ColorIndex Or ячейки.Interior.ColorIndex = цвет.Interior.ColorIndex Then .Item(ячейки.MergeArea.Address) = "" End If Next КЦВ = .Count End With End Function
[/vba]
Взял код Alex ST
Теперь считает обьедененные области + ячейки окрашенные определенным цветом.
ЗЫ: Увидел ваше решение уже после того, как запостил свое Спасибо за помощь.
Допилил используя временный словарь: [vba]
Код
Function КЦВ(диапазон As Range, цвет As Range) Application.Volatile True Dim ячейки As Range With CreateObject("Scripting.Dictionary") For Each ячейки In диапазон If ячейки.MergeCells And ячейки.Interior.ColorIndex = цвет.Interior.ColorIndex Or ячейки.Interior.ColorIndex = цвет.Interior.ColorIndex Then .Item(ячейки.MergeArea.Address) = "" End If Next КЦВ = .Count End With End Function
[/vba]
Взял код Alex ST
Теперь считает обьедененные области + ячейки окрашенные определенным цветом.
ЗЫ: Увидел ваше решение уже после того, как запостил свое Спасибо за помощь.SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Воскресенье, 23.06.2013, 20:51