Help!! Помогите с подсчётом суммы ячеек с один цветом текста

[svit82]

Нужно в выделенном диапазоне подсчитать сумму значений в ячейках с одинаковым цветом текста. Макрос такой:

Код: Выделить всё


Public MyArray(40000, 1) As Double
Public MyArray1(40000, 1) As Double
Public I As Integer

Public Function countByColor(R As Range, Color As String)
    Summ = 0
    I = 0
    For Each c In R
'    MsgBox (c.Font.Color)
    MyArray(I, 0) = c.Font.Color
    MyArray(I, 1) = c.Value
    I = I + 1
    Next c
    countByColor = MyArray
End Function
Sub test()
Dim testrow As Double
Dim N As Integer
Dim B As Integer
B = 0
' MsgBox ActiveWindow.RangeSelection.Address
' MsgBox (countByColor(Range(ActiveWindow.RangeSelection.Address), "0"))
result = countByColor(Range(ActiveWindow.RangeSelection.Address), "0")
'MsgBox (MyArray(0, 0))
' WordBasic.SortArray MyArray()
For N = 0 To (I - 1)
MyArray1(N, 1) = 0
testrow = MyArray(N, 0)
For m = N To (I - 1)
If ((MyArray(m, 0) = testrow) And (MyArray(m, 0) <> 1.1)) Then
MyArray1(N, 0) = testrow
MyArray1(N, 1) = MyArray1(N, 1) + MyArray(m, 1)
MyArray(m, 0) = 1.1

If (m = N) Then
B = B + 1
End If

End If
Next m
Next N

For m = 0 To (B - 1)
Range("A" & m + 15 & ":A" & m + 15).Interior.Color = MyArray1(m, 0)
Range("B" & m + 15 & ":B" & m + 15).Font.Color = MyArray1(m, 0)
Range("B" & m + 15 & ":B" & m + 15).Value = MyArray1(m, 1)
Next m

End Sub



И вот не получается отыскать ошибку - считает только 4 цвета. Если ещё один добавить - сразу глючит. В чём грабли?

[$€rg]

разбираться не стал так набросал, вроде работает

Код: Выделить всё

Sub o()
Dim c As Range, i As String, j As New Collection, k As Integer
Dim z() As Long
On Error Resume Next
For Each c In Selection
If c.Font.Color <> 0 Then
i = CStr(c.Font.Color)
j.Add i, i
End If
Next
ReDim z(j.Count)
For k = 1 To j.Count
For Each c In Selection
If CStr(c.Font.Color) = j.Item(k) Then
z(k) = c.Value + z(k)
End If
Next
Debug.Print z(k)
Next k
End Sub


[svit82]

разбираться не стал так набросал, вроде работает

Ещё как работает! СПАСИБО!!!!
И всё гораздо проще

[$€rg]

видимо не будет ошибкой за один цикл пройти, имхо красивее

Код: Выделить всё

Sub o()
   Dim c As Range, j As New Collection
   Dim z() As Long, n As Long
   On Error Resume Next
   ReDim z(1 To Selection.Count)
   For Each c In Selection
      n = c.Font.Color
      j.Add j.Count + 1, CStr(n)
      n = j.Item(CStr(n))
      z(n) = z(n) + c.Value
   Next
   ReDim Preserve z(j.Count)
End Sub

[svit82]

видимо не будет ошибкой за один цикл пройти, имхо красивее

Нет предела совершенству