ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   count colored cells (https://www.excelbanter.com/excel-programming/355570-count-colored-cells.html)

apx2001
count colored cells
 

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile: http://www.excelforum.com/member.php...o&userid=32306
View this thread: http://www.excelforum.com/showthread...hreadid=520593

Bob Phillips[_6_]
count colored cells
 
See http://www.xldynamic.com/source/xld.ColourCounter.html for a working
solution

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

"apx2001" wrote in
message ...

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile:
http://www.excelforum.com/member.php...o&userid=32306
View this thread: http://www.excelforum.com/showthread...hreadid=520593

RB Smissaert
count colored cells
 
Sub test()

Dim c As Range
Dim i As Long

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < -4142 Then
i = i + 1
End If
Next

MsgBox i & " cells with a colour format", , _
"counting coloured cells"

End Sub


RBS


"apx2001" wrote in
message ...

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile:
http://www.excelforum.com/member.php...o&userid=32306
View this thread: http://www.excelforum.com/showthread...hreadid=520593

apx2001[_2_]
count colored cells
 

thank you for your help and the reference!

best,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile: http://www.excelforum.com/member.php...o&userid=32306
View this thread: http://www.excelforum.com/showthread...hreadid=520593

RB Smissaert
count colored cells
 
This gives more information:

Sub test()

Dim c As Range
Dim i As Long
Dim n As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & arrColours(n, 2)
End If
Next

MsgBox i & " cells with a colour format" & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------" & vbCrLf & _
strColours, , _
"counting coloured cells"

End Sub


RBS



"RB Smissaert" wrote in message
...
Sub test()

Dim c As Range
Dim i As Long

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < -4142 Then
i = i + 1
End If
Next

MsgBox i & " cells with a colour format", , _
"counting coloured cells"

End Sub


RBS


"apx2001" wrote in
message ...

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile:
http://www.excelforum.com/member.php...o&userid=32306
View this thread:
http://www.excelforum.com/showthread...hreadid=520593

RB Smissaert
count colored cells
 
Added a counter, just for in case you were dealing with a very large range.

Sub CountColours()

Dim c As Range
Dim i As Long
Dim n As Long
Dim x As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String
Dim lCellCount As Long

lCellCount = ActiveSheet.UsedRange.Cells.Count

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
x = x + 1
If x Mod lCellCount \ 100 = 0 Then
Application.StatusBar = " " & _
Round((x / lCellCount), 2) _
* 100 & _
" % done"
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & _
arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & _
arrColours(n, 2)
End If
Next

MsgBox i & " cells with a colour format" & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------" & vbCrLf & _
strColours, , _
"counting coloured cells"

Application.StatusBar = False

End Sub


RBS


"RB Smissaert" wrote in message
...
This gives more information:

Sub test()

Dim c As Range
Dim i As Long
Dim n As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & arrColours(n, 2)
End If
Next

MsgBox i & " cells with a colour format" & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------" & vbCrLf & _
strColours, , _
"counting coloured cells"

End Sub


RBS



"RB Smissaert" wrote in message
...
Sub test()

Dim c As Range
Dim i As Long

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < -4142 Then
i = i + 1
End If
Next

MsgBox i & " cells with a colour format", , _
"counting coloured cells"

End Sub


RBS


"apx2001" wrote in
message ...

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile:
http://www.excelforum.com/member.php...o&userid=32306
View this thread:
http://www.excelforum.com/showthread...hreadid=520593

RB Smissaert
count colored cells
 
Fixed a division by zero bug:

Sub CountColours()

Dim c As Range
Dim i As Long
Dim n As Long
Dim x As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String
Dim lCellCount As Long

lCellCount = ActiveSheet.UsedRange.Cells.Count

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
If lCellCount 10000 Then
x = x + 1
If x Mod lCellCount \ 100 = 0 Then
Application.StatusBar = " " & _
Round((x / lCellCount), 2) _
* 100 & _
" % done"
End If
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & _
arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & _
arrColours(n, 2)
End If
Next

MsgBox "Used range with " & lCellCount & " cells." & _
vbCrLf & _
i & " cells with a colour format." & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------------------" & _
vbCrLf & _
strColours, , _
"counting coloured cells"

If lCellCount 10000 Then
Application.StatusBar = False
End If

End Sub


RBS


"RB Smissaert" wrote in message
...
Added a counter, just for in case you were dealing with a very large
range.

Sub CountColours()

Dim c As Range
Dim i As Long
Dim n As Long
Dim x As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String
Dim lCellCount As Long

lCellCount = ActiveSheet.UsedRange.Cells.Count

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
x = x + 1
If x Mod lCellCount \ 100 = 0 Then
Application.StatusBar = " " & _
Round((x / lCellCount), 2) _
* 100 & _
" % done"
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & _
arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & _
arrColours(n, 2)
End If
Next

MsgBox i & " cells with a colour format" & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------" & vbCrLf & _
strColours, , _
"counting coloured cells"

Application.StatusBar = False

End Sub


RBS


"RB Smissaert" wrote in message
...
This gives more information:

Sub test()

Dim c As Range
Dim i As Long
Dim n As Long
Dim vIndex
Dim nMax As Long
Dim arrColours(1 To 255, 1 To 2) As Long
Dim strColours As String

For Each c In ActiveSheet.UsedRange
vIndex = c.Interior.ColorIndex
For n = 1 To nMax + 1
If vIndex = arrColours(n, 1) Then
arrColours(n, 2) = arrColours(n, 2) + 1
If n nMax Then
nMax = n
End If
Exit For
End If
If arrColours(n, 1) = 0 Then
arrColours(n, 1) = vIndex
arrColours(n, 2) = 1
nMax = n
End If
Next
If vIndex 0 Then
i = i + 1
End If
Next

For n = 1 To nMax
If n 1 Then
strColours = strColours & vbCrLf & _
arrColours(n, 1) & vbTab & arrColours(n, 2)
Else
strColours = arrColours(n, 1) & vbTab & arrColours(n, 2)
End If
Next

MsgBox i & " cells with a colour format" & _
vbCrLf & vbCrLf & _
"index" & vbTab & "count" & vbCrLf & _
"-----------------------" & vbCrLf & _
strColours, , _
"counting coloured cells"

End Sub


RBS



"RB Smissaert" wrote in message
...
Sub test()

Dim c As Range
Dim i As Long

For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < -4142 Then
i = i + 1
End If
Next

MsgBox i & " cells with a colour format", , _
"counting coloured cells"

End Sub


RBS


"apx2001" wrote
in message ...

i have been trying to figure out a macro that counts cells with an
interior color other than white and display the results in a message
box.

any suggestions are highly appreciated!
thanks,
johannes


--
apx2001
------------------------------------------------------------------------
apx2001's Profile:
http://www.excelforum.com/member.php...o&userid=32306
View this thread:
http://www.excelforum.com/showthread...hreadid=520593


All times are GMT +1. The time now is 01:16 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com