Помогите пожлуйста апгрейдить функцию по подсчету количества (или суммы ячеек (думаю функции будут почти одинаковые)) ячеек по нескольким условиям: 1 условие : Цвет ячейки 2 условие : Цвет шрифта в ячейке 3 условие : Значение в ячейке лежит в заданном диапазоне (для этой цели есть встроенная функция "Счетеслимн" , но она не учитывает цвет шрифта и заливки ячеек).
По отдельности удалось написать функцию подсчета Количества ячеек по 1 и 2 условию (см код ниже и вложенный файл), то есть функция Колцвет считает количество ячеек с определенным цветом шрифта, а функция Колзаливка считает количество ячеек с определенным цветом заливки.
Нужно написать универсальную функцию типа "Счетеслимн" , которая считает количество ячеек не только по заданному диапазону, но и с учетом цвета шрифта и цвета заливки...
[vba]
Код
'Формуда КОЛИЧЕСТВА ячеек во цвету шрифта Public Function КОЛЦВЕТ(ДИАПАЗОН As Range, ЯЧЕЙКА) As Double Dim S As Double Dim rCell As Range Dim ColCell As Long
ColCell = ЯЧЕЙКА.Font.Color S = 0
For Each rCell In ДИАПАЗОН If rCell.Font.Color = ColCell Then S = S + 1 End If Next
КОЛЦВЕТ = S End Function
'Формуда КОЛИЧЕСТВА ячеек во цвету заливки Public Function КОЛЗАЛИВКА(ДИАПАЗОН As Range, ЯЧЕЙКА) As Double Dim S As Double Dim rCell As Range Dim ColCell As Long
ColCell = ЯЧЕЙКА.Interior.Color S = 0
For Each rCell In ДИАПАЗОН If rCell.Interior.Color = ColCell Then S = S + 1 End If Next
КОЛЗАЛИВКА = S End Function
[/vba]
Всем привет.
Помогите пожлуйста апгрейдить функцию по подсчету количества (или суммы ячеек (думаю функции будут почти одинаковые)) ячеек по нескольким условиям: 1 условие : Цвет ячейки 2 условие : Цвет шрифта в ячейке 3 условие : Значение в ячейке лежит в заданном диапазоне (для этой цели есть встроенная функция "Счетеслимн" , но она не учитывает цвет шрифта и заливки ячеек).
По отдельности удалось написать функцию подсчета Количества ячеек по 1 и 2 условию (см код ниже и вложенный файл), то есть функция Колцвет считает количество ячеек с определенным цветом шрифта, а функция Колзаливка считает количество ячеек с определенным цветом заливки.
Нужно написать универсальную функцию типа "Счетеслимн" , которая считает количество ячеек не только по заданному диапазону, но и с учетом цвета шрифта и цвета заливки...
[vba]
Код
'Формуда КОЛИЧЕСТВА ячеек во цвету шрифта Public Function КОЛЦВЕТ(ДИАПАЗОН As Range, ЯЧЕЙКА) As Double Dim S As Double Dim rCell As Range Dim ColCell As Long
ColCell = ЯЧЕЙКА.Font.Color S = 0
For Each rCell In ДИАПАЗОН If rCell.Font.Color = ColCell Then S = S + 1 End If Next
КОЛЦВЕТ = S End Function
'Формуда КОЛИЧЕСТВА ячеек во цвету заливки Public Function КОЛЗАЛИВКА(ДИАПАЗОН As Range, ЯЧЕЙКА) As Double Dim S As Double Dim rCell As Range Dim ColCell As Long
ColCell = ЯЧЕЙКА.Interior.Color S = 0
For Each rCell In ДИАПАЗОН If rCell.Interior.Color = ColCell Then S = S + 1 End If Next
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=")
For Each oCell In RNG If oCell.Interior.Color = rngColorFill.Interior.Color Then If oCell.Font.Color = rngColorFont.Font.Color Then iFulfillment = -1 For Each Condition In Conditions For iChar = 1 To Len(Condition) sChar = Mid(Condition, iChar, 1) For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For Next If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For Next If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=" Select Case sChar Case ">" If oCell.Value > CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<" If oCell.Value < CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value End If End If Next SumByConditions = dSum End Function
[/vba]
t330, [vba]
Код
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=")
For Each oCell In RNG If oCell.Interior.Color = rngColorFill.Interior.Color Then If oCell.Font.Color = rngColorFont.Font.Color Then iFulfillment = -1 For Each Condition In Conditions For iChar = 1 To Len(Condition) sChar = Mid(Condition, iChar, 1) For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For Next If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For Next If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=" Select Case sChar Case ">" If oCell.Value > CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<" If oCell.Value < CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value End If End If Next SumByConditions = dSum End Function
Уважаемый, Boa! Спасибо за код! Формула прекрасно работает:) даже лучше , чем мои по -отдельности взятые функции, которые почему-то не могут отличить "черный" цвет шрифта от цвета шрифта в пустой ячейке и поэтому мои функции по подсчету количества ячеек в диапазоне где есть ячейки с черным шрифтом и есть пустые ячейки не работает... А Ваша функция работает везде...
Второй день пытаюсь понять логику работы Вашего кода и никак не осилю.
Не могли бы Вы в комментариях более подробно описать для чего нужны объявленные переменные (например какую роль выполняет переменная iFulfilment ?) и что делают вложенные функции и условия... К примеру, в строке 10 ( в коде ниже) есть условие , что If iSymbol > UBound(ArrSymbols) , но разве это условие хоть когда-то может быть выполниться , когда в строке 9 указано , что iSymbol не может быть больше UBound(ArrSymbols) (For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols))
Также непонятно условие в строке 20 If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=". Разве ichar может когда-то быть равен или меньше 0 с учетом того , что условие в строке 10 тоже никогда не исполняется...?
Если не трудно поясните пожалуйста как работает код...
[vba]
Код
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=")
For Each oCell In RNG If oCell.Interior.Color = rngColorFill.Interior.Color Then If oCell.Font.Color = rngColorFont.Font.Color Then iFulfillment = -1 For Each Condition In Conditions For iChar = 1 To Len(Condition) sChar = Mid(Condition, iChar, 1) 9 For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For Next 10 If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For Next 20 If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=" Select Case sChar Case ">" If oCell.Value > CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<" If oCell.Value < CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value End If End If Next SumByConditions = dSum End Function
[/vba]
Уважаемый, Boa! Спасибо за код! Формула прекрасно работает:) даже лучше , чем мои по -отдельности взятые функции, которые почему-то не могут отличить "черный" цвет шрифта от цвета шрифта в пустой ячейке и поэтому мои функции по подсчету количества ячеек в диапазоне где есть ячейки с черным шрифтом и есть пустые ячейки не работает... А Ваша функция работает везде...
Второй день пытаюсь понять логику работы Вашего кода и никак не осилю.
Не могли бы Вы в комментариях более подробно описать для чего нужны объявленные переменные (например какую роль выполняет переменная iFulfilment ?) и что делают вложенные функции и условия... К примеру, в строке 10 ( в коде ниже) есть условие , что If iSymbol > UBound(ArrSymbols) , но разве это условие хоть когда-то может быть выполниться , когда в строке 9 указано , что iSymbol не может быть больше UBound(ArrSymbols) (For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols))
Также непонятно условие в строке 20 If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=". Разве ichar может когда-то быть равен или меньше 0 с учетом того , что условие в строке 10 тоже никогда не исполняется...?
Если не трудно поясните пожалуйста как работает код...
[vba]
Код
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=")
For Each oCell In RNG If oCell.Interior.Color = rngColorFill.Interior.Color Then If oCell.Font.Color = rngColorFont.Font.Color Then iFulfillment = -1 For Each Condition In Conditions For iChar = 1 To Len(Condition) sChar = Mid(Condition, iChar, 1) 9 For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For Next 10 If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For Next 20 If iChar > 0 Then sChar = Mid(Condition, 1, iChar) Else sChar = "=" Select Case sChar Case ">" If oCell.Value > CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<" If oCell.Value < CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value End If End If Next SumByConditions = dSum End Function
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True ' Делаем функцию волатильной, что бы она пересчитывалась при любых изменениях на листе Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=") ' массив символов сравнения
For Each oCell In RNG ' проверяем каждую ячейку из объявленного диапазона If oCell.Interior.Color = rngColorFill.Interior.Color Then ' если заливка проверяемой ячейки совпадает с цветом ячейки заданной в условии rngColorFill If oCell.Font.Color = rngColorFont.Font.Color Then ' если цвет шрифта совпадает, то идем дальше... iFulfillment = -1 ' так как в функции параметры можем задавать не одним значением, а массивом (2-мя и более), то задаем значение меньше минимального индекса массива <0 For Each Condition In Conditions ' перебираем все наши условия For iChar = 1 To VBA.Len(Condition) ' проверяем каждый символ начиная с 1-го на принадлежность массиву символов ArrSymbols sChar = VBA.Mid(Condition, iChar, 1) ' т.е. отрезаем по одному For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For ' если находим, то выходим из цикла и соответственно iSymbol максимум может быть равен UBound(ArrSymbols) Next If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For ' если после прохождения цикла iSymbol > UBound(ArrSymbols), то sChar не принадлежит массиву ArrSymbols и с символа iChar идет сравниваемое значение, соответственно мы отнимаем единицу, что бы iChar был равен последнему символу оператора сравнения Next If iChar > 0 Then sChar = VBA.Mid(Condition, 1, iChar) Else sChar = "=" ' iChar > 0, то оператор сравнения есть и мы его вырезаем, если iChar = 0, то оператора сравнения нет и соответственно значение в проверяемой ячейке должно быть равно сравниваемому значению, поэтому и присваиваем sChar = "=". Т.е. всё как в функции "Счетеслимн" Select Case sChar ' в зависимости от символа сравнения sChar делаем сравнение. Case ">" If oCell.Value > CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 ' если условие выполняется, то прибавляем 1 Case "<" If oCell.Value < CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value ' если все условия из массива условий выполнились, то iFulfillment = UBound(Conditions). Если хотя бы одно условие не выполнится, то этого равенства не будет End If End If Next SumByConditions = dSum End Function
[/vba]
t330, функция с комментариями
[vba]
Код
Option Explicit
Function SumByConditions(RNG As Range, rngColorFill As Range, rngColorFont As Range, ParamArray Conditions() As Variant) '' Author: boa '' Written: 11.09.2019 '' Edited: ' Description: суммирует ячейки с учетом заливки, цвета шрифта и условий >,<,=,<> Application.Volatile True ' Делаем функцию волатильной, что бы она пересчитывалась при любых изменениях на листе Dim oCell As Range Dim dSum As Double Dim sChar As String Dim Condition Dim iChar As Integer Dim iSymbol As Integer Dim iFulfillment As Integer Dim ArrSymbols(): ArrSymbols = Array(">", "<", "=") ' массив символов сравнения
For Each oCell In RNG ' проверяем каждую ячейку из объявленного диапазона If oCell.Interior.Color = rngColorFill.Interior.Color Then ' если заливка проверяемой ячейки совпадает с цветом ячейки заданной в условии rngColorFill If oCell.Font.Color = rngColorFont.Font.Color Then ' если цвет шрифта совпадает, то идем дальше... iFulfillment = -1 ' так как в функции параметры можем задавать не одним значением, а массивом (2-мя и более), то задаем значение меньше минимального индекса массива <0 For Each Condition In Conditions ' перебираем все наши условия For iChar = 1 To VBA.Len(Condition) ' проверяем каждый символ начиная с 1-го на принадлежность массиву символов ArrSymbols sChar = VBA.Mid(Condition, iChar, 1) ' т.е. отрезаем по одному For iSymbol = LBound(ArrSymbols) To UBound(ArrSymbols) If sChar = ArrSymbols(iSymbol) Then Exit For ' если находим, то выходим из цикла и соответственно iSymbol максимум может быть равен UBound(ArrSymbols) Next If iSymbol > UBound(ArrSymbols) Then iChar = iChar - 1: Exit For ' если после прохождения цикла iSymbol > UBound(ArrSymbols), то sChar не принадлежит массиву ArrSymbols и с символа iChar идет сравниваемое значение, соответственно мы отнимаем единицу, что бы iChar был равен последнему символу оператора сравнения Next If iChar > 0 Then sChar = VBA.Mid(Condition, 1, iChar) Else sChar = "=" ' iChar > 0, то оператор сравнения есть и мы его вырезаем, если iChar = 0, то оператора сравнения нет и соответственно значение в проверяемой ячейке должно быть равно сравниваемому значению, поэтому и присваиваем sChar = "=". Т.е. всё как в функции "Счетеслимн" Select Case sChar ' в зависимости от символа сравнения sChar делаем сравнение. Case ">" If oCell.Value > CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 ' если условие выполняется, то прибавляем 1 Case "<" If oCell.Value < CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case ">=", "=>" If oCell.Value >= CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<=", "=<" If oCell.Value <= CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case "<>" If oCell.Value <> CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 Case Else If oCell.Value = CDbl(VBA.Mid(Condition, iChar + 1)) Then iFulfillment = iFulfillment + 1 End Select Next If iFulfillment = UBound(Conditions) Then dSum = dSum + oCell.Value ' если все условия из массива условий выполнились, то iFulfillment = UBound(Conditions). Если хотя бы одно условие не выполнится, то этого равенства не будет End If End If Next SumByConditions = dSum End Function