Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Функция подсчета суммы и количества ячеек с условием - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Функция подсчета суммы и количества ячеек с условием (Макросы/Sub)
Функция подсчета суммы и количества ячеек с условием
t330 Дата: Вторник, 10.09.2019, 18:30 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Всем привет.

Помогите пожлуйста апгрейдить функцию по подсчету количества (или суммы ячеек (думаю функции будут почти одинаковые)) ячеек по нескольким условиям:
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]
К сообщению приложен файл: 3715731.xlsm (20.2 Kb)
 
Ответить
СообщениеВсем привет.

Помогите пожлуйста апгрейдить функцию по подсчету количества (или суммы ячеек (думаю функции будут почти одинаковые)) ячеек по нескольким условиям:
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]

Автор - t330
Дата добавления - 10.09.2019 в 18:30
boa Дата: Среда, 11.09.2019, 12:06 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 549
Репутация: 167 ±
Замечаний: 0% ±

365
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
[/vba]
К сообщению приложен файл: SumByConditions.xlsm (30.2 Kb)




Сообщение отредактировал boa - Среда, 11.09.2019, 12:07
 
Ответить
Сообщение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
[/vba]

Автор - boa
Дата добавления - 11.09.2019 в 12:06
t330 Дата: Четверг, 12.09.2019, 15:51 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Уважаемый, 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

[/vba]

Автор - t330
Дата добавления - 12.09.2019 в 15:51
krosav4ig Дата: Четверг, 12.09.2019, 18:12 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
t330, при нотации [vba]
Код
    For a = b To c Step d
       DoEvents
    Next
[/vba] оператор Next прибавляет приращение d (по умолчанию 1) к итератору a независимо от значения последнего (за исключением случая
Код
(c > b) Imp (d < 0)
)
к примеру, выполните в Immediate [vba]
Код
For i=0 To 0:?i:Next:?i
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениеt330, при нотации [vba]
Код
    For a = b To c Step d
       DoEvents
    Next
[/vba] оператор Next прибавляет приращение d (по умолчанию 1) к итератору a независимо от значения последнего (за исключением случая
Код
(c > b) Imp (d < 0)
)
к примеру, выполните в Immediate [vba]
Код
For i=0 To 0:?i:Next:?i
[/vba]

Автор - krosav4ig
Дата добавления - 12.09.2019 в 18:12
boa Дата: Четверг, 12.09.2019, 18:43 | Сообщение № 5
Группа: Друзья
Ранг: Ветеран
Сообщений: 549
Репутация: 167 ±
Замечаний: 0% ±

365
t330,
функция с комментариями




Сообщение отредактировал boa - Четверг, 12.09.2019, 18:45
 
Ответить
Сообщениеt330,
функция с комментариями

Автор - boa
Дата добавления - 12.09.2019 в 18:43
t330 Дата: Пятница, 13.09.2019, 03:19 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
krosav4ig и boa

Огромное спасибо за разъяснения!
Особенно boa за подробные комментарии к функции.

Сделал из нее стандартную процедуру , чтобы дебагером пробежаться по переменным в окне Locals и вообще всё прояснилось.
Спасибо!
 
Ответить
Сообщениеkrosav4ig и boa

Огромное спасибо за разъяснения!
Особенно boa за подробные комментарии к функции.

Сделал из нее стандартную процедуру , чтобы дебагером пробежаться по переменным в окне Locals и вообще всё прояснилось.
Спасибо!

Автор - t330
Дата добавления - 13.09.2019 в 03:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Функция подсчета суммы и количества ячеек с условием (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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