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

Вход

Регистрация

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

 

= Мир MS Excel/VBA для суммы по цвету шрифта - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » VBA для суммы по цвету шрифта (Макросы/Sub)
VBA для суммы по цвету шрифта
Dzianis Дата: Понедельник, 14.11.2022, 16:05 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Добрый день, столкнулся с проблемой. Необходим скрипт VBA для суммы по цвету шрифта, на просторах интернета такое имеется, но только для версий Excel 2010 +, а на работе версия 1997-2003-- не принимает код и выводит ошибку в цикле VBA. Помогите пожалуйста с изменением кода под версию Excel 97-03 либо если имеются "ГУРУ Excel" подскажите скрипт VBA. Спасибо. P.S. скрипт прикрепляю ниже
[vba]
Код
----------------------------
Function GetCellColor(xlRange As Range)
Dim indRow, indColumn As Long
Dim arResults()

Application.Volatile

If xlRange Is Nothing Then
Set xlRange = Application.ThisCell
End If

If xlRange.Count > 1 Then
ReDim arResults(1 To xlRange.Rows.Count, 1 To xlRange.Columns.Count)
For indRow = 1 To xlRange.Rows.Count
For indColumn = 1 To xlRange.Columns.Count
arResults(indRow, indColumn) = xlRange(indRow, indColumn).Interior.Color
Next
Next
GetCellColor = arResults
Else
GetCellColor = xlRange.Interior.Color
End If
End Function

Function GetCellFontColor(xlRange As Range)
Dim indRow, indColumn As Long
Dim arResults()

Application.Volatile

If xlRange Is Nothing Then
Set xlRange = Application.ThisCell
End If

If xlRange.Count > 1 Then
ReDim arResults(1 To xlRange.Rows.Count, 1 To xlRange.Columns.Count)
For indRow = 1 To xlRange.Rows.Count
For indColumn = 1 To xlRange.Columns.Count
arResults(indRow, indColumn) = xlRange(indRow, indColumn).Font.Color
Next
Next
GetCellFontColor = arResults
Else
GetCellFontColor = xlRange.Font.Color
End If

End Function

Function CountCellsByColor(rData As Range, cellRefColor As Range) As Long
Dim indRefColor As Long
Dim cellCurrent As Range
Dim cntRes As Long

Application.Volatile
cntRes = 0
indRefColor = cellRefColor.Cells(1, 1).Interior.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Interior.Color Then
cntRes = cntRes + 1
End If
Next cellCurrent

CountCellsByColor = cntRes
End Function

Function SumCellsByColor(rData As Range, cellRefColor As Range)
Dim indRefColor As Long
Dim cellCurrent As Range
Dim sumRes

Application.Volatile
sumRes = 0
indRefColor = cellRefColor.Cells(1, 1).Interior.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Interior.Color Then
sumRes = WorksheetFunction.Sum(cellCurrent, sumRes)
End If
Next cellCurrent

SumCellsByColor = sumRes
End Function

Function CountCellsByFontColor(rData As Range, cellRefColor As Range) As Long
Dim indRefColor As Long
Dim cellCurrent As Range
Dim cntRes As Long

Application.Volatile
cntRes = 0
indRefColor = cellRefColor.Cells(1, 1).Font.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Font.Color Then
cntRes = cntRes + 1
End If
Next cellCurrent

CountCellsByFontColor = cntRes
End Function

Function SumCellsByFontColor(rData As Range, cellRefColor As Range)
Dim indRefColor As Long
Dim cellCurrent As Range
Dim sumRes

Application.Volatile
sumRes = 0
indRefColor = cellRefColor.Cells(1, 1).Font.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Font.Color Then
sumRes = WorksheetFunction.Sum(cellCurrent, sumRes)
End If
Next cellCurrent

SumCellsByFontColor = sumRes
End Function
-----------------------------------
[/vba]


Сообщение отредактировал Serge_007 - Понедельник, 14.11.2022, 17:51
 
Ответить
СообщениеДобрый день, столкнулся с проблемой. Необходим скрипт VBA для суммы по цвету шрифта, на просторах интернета такое имеется, но только для версий Excel 2010 +, а на работе версия 1997-2003-- не принимает код и выводит ошибку в цикле VBA. Помогите пожалуйста с изменением кода под версию Excel 97-03 либо если имеются "ГУРУ Excel" подскажите скрипт VBA. Спасибо. P.S. скрипт прикрепляю ниже
[vba]
Код
----------------------------
Function GetCellColor(xlRange As Range)
Dim indRow, indColumn As Long
Dim arResults()

Application.Volatile

If xlRange Is Nothing Then
Set xlRange = Application.ThisCell
End If

If xlRange.Count > 1 Then
ReDim arResults(1 To xlRange.Rows.Count, 1 To xlRange.Columns.Count)
For indRow = 1 To xlRange.Rows.Count
For indColumn = 1 To xlRange.Columns.Count
arResults(indRow, indColumn) = xlRange(indRow, indColumn).Interior.Color
Next
Next
GetCellColor = arResults
Else
GetCellColor = xlRange.Interior.Color
End If
End Function

Function GetCellFontColor(xlRange As Range)
Dim indRow, indColumn As Long
Dim arResults()

Application.Volatile

If xlRange Is Nothing Then
Set xlRange = Application.ThisCell
End If

If xlRange.Count > 1 Then
ReDim arResults(1 To xlRange.Rows.Count, 1 To xlRange.Columns.Count)
For indRow = 1 To xlRange.Rows.Count
For indColumn = 1 To xlRange.Columns.Count
arResults(indRow, indColumn) = xlRange(indRow, indColumn).Font.Color
Next
Next
GetCellFontColor = arResults
Else
GetCellFontColor = xlRange.Font.Color
End If

End Function

Function CountCellsByColor(rData As Range, cellRefColor As Range) As Long
Dim indRefColor As Long
Dim cellCurrent As Range
Dim cntRes As Long

Application.Volatile
cntRes = 0
indRefColor = cellRefColor.Cells(1, 1).Interior.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Interior.Color Then
cntRes = cntRes + 1
End If
Next cellCurrent

CountCellsByColor = cntRes
End Function

Function SumCellsByColor(rData As Range, cellRefColor As Range)
Dim indRefColor As Long
Dim cellCurrent As Range
Dim sumRes

Application.Volatile
sumRes = 0
indRefColor = cellRefColor.Cells(1, 1).Interior.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Interior.Color Then
sumRes = WorksheetFunction.Sum(cellCurrent, sumRes)
End If
Next cellCurrent

SumCellsByColor = sumRes
End Function

Function CountCellsByFontColor(rData As Range, cellRefColor As Range) As Long
Dim indRefColor As Long
Dim cellCurrent As Range
Dim cntRes As Long

Application.Volatile
cntRes = 0
indRefColor = cellRefColor.Cells(1, 1).Font.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Font.Color Then
cntRes = cntRes + 1
End If
Next cellCurrent

CountCellsByFontColor = cntRes
End Function

Function SumCellsByFontColor(rData As Range, cellRefColor As Range)
Dim indRefColor As Long
Dim cellCurrent As Range
Dim sumRes

Application.Volatile
sumRes = 0
indRefColor = cellRefColor.Cells(1, 1).Font.Color
For Each cellCurrent In rData
If indRefColor = cellCurrent.Font.Color Then
sumRes = WorksheetFunction.Sum(cellCurrent, sumRes)
End If
Next cellCurrent

SumCellsByFontColor = sumRes
End Function
-----------------------------------
[/vba]

Автор - Dzianis
Дата добавления - 14.11.2022 в 16:05
Serge_007 Дата: Понедельник, 14.11.2022, 17:53 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16475
Репутация: 2748 ±
Замечаний: ±

Excel 2016
Здравствуйте

выводит ошибку в цикле
На какой строке выдает ошибку?


ЮMoney:41001419691823 | WMR:126292472390
 
Ответить
СообщениеЗдравствуйте

выводит ошибку в цикле
На какой строке выдает ошибку?

Автор - Serge_007
Дата добавления - 14.11.2022 в 17:53
Kuzmich Дата: Понедельник, 14.11.2022, 19:29 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
Цитата
версия 1997-2003-- не принимает код и выводит ошибку в цикле VBA

Приведите пример
 
Ответить
Сообщение
Цитата
версия 1997-2003-- не принимает код и выводит ошибку в цикле VBA

Приведите пример

Автор - Kuzmich
Дата добавления - 14.11.2022 в 19:29
Dzianis Дата: Среда, 16.11.2022, 11:07 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Компилятор выделяет все строки цикла с оператором For
 
Ответить
СообщениеКомпилятор выделяет все строки цикла с оператором For

Автор - Dzianis
Дата добавления - 16.11.2022 в 11:07
Dzianis Дата: Среда, 16.11.2022, 11:32 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Извиняюсь за ракурс и способ
К сообщению приложен файл: 7638904.jpg (55.0 Kb)
 
Ответить
СообщениеИзвиняюсь за ракурс и способ

Автор - Dzianis
Дата добавления - 16.11.2022 в 11:32
Dzianis Дата: Среда, 16.11.2022, 11:36 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Приведите пример
К сообщению приложен файл: 3192135.jpg (55.0 Kb)
 
Ответить
СообщениеПриведите пример

Автор - Dzianis
Дата добавления - 16.11.2022 в 11:36
Kuzmich Дата: Среда, 16.11.2022, 12:46 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
Пример в формате .xls
 
Ответить
СообщениеПример в формате .xls

Автор - Kuzmich
Дата добавления - 16.11.2022 в 12:46
Мир MS Excel » Вопросы и решения » Вопросы по VBA » VBA для суммы по цвету шрифта (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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