PDA

View Full Version : [SOLVED] Count_Colours_Not_Duplicate

RIC63
12-31-2017, 02:28 AM
Hi everybody,

I looked through the posts but I can not find something close to what I intend to do:

count how many different colours are present in specific areas : if nothing is present then will be returned the letter 'n' if are present some values but no colours then will be returned one zero, if coloured cells are present only the total number of colour found will be returned ( no duplicate ) see the attached screenshot were i have manually analized areas P132:R153 , S132:U153, V132:X153, Y132:AA153.....and returned values in row 159

if anyone has something that can be useful for the purpose I would be very grateful

riccardo

Fennek
12-31-2017, 03:38 AM
Hallo,

try with this (untested)

Sub Fen()
ls = cells(132, columns.count).end(xltoleft).column
With CreateObject("Scripting.Dictionary")
for j = 19 to ls step 3
set rng = range(cells(132, j),cells(153, j+2)
for each c in rng
.Item(c.Interior.Color) = .Item(c.Interior.Color) + 1
next cl
cells(159, j) = .count
.removeall
Next j
End With
End Sub

regards

RIC63
12-31-2017, 09:42 AM
Hi Fennek,

the only thing I could do is change the syntax for the macro to work but it does not do the work I needed :

Sub Fen()
ls = cells(132, columns.count).end(xltoleft).column
With CreateObject("Scripting.Dictionary")
For j = 19 To ls Step 3
Set rng = range(cells(132, j),cells(153, j+2))
For Each c In rng
.Item(c.Interior.Color) = .Item(c.Interior.Color) + 1
Next c
cells(159, j) = .count
.removeall
Next j
End With
End Sub

thanks anyway

I take this opportunity to wish you a happy new year
riccardo

mana
12-31-2017, 08:19 PM
Option Explicit

Sub test()
Dim cc As Range, c As Range
Dim dic As Object
Dim i As Long

Set cc = Range("b2:n10").Columns

Set dic = CreateObject("scripting.dictionary")

For i = 1 To cc.Count Step 3
For Each c In cc(i).Resize(, 3).Cells
If c.Interior.ColorIndex <> xlNone Then
dic(c.Interior.ColorIndex) = Empty
End If
Next
cc(i).Cells(1).Offset(cc.Rows.Count + 6, 1).Value = dic.Count
dic.RemoveAll
Next

End Sub

マナ

RIC63
01-01-2018, 01:39 PM
thanks mana
the code performs what I wanted... there is only one small thing, 0 (zero) is returned even when there is no data in the analyzed range and it should have returned n

in any case, I really appreciate the help

thanks again and happy 2018

mana
01-01-2018, 04:29 PM
Option Explicit

Sub test()
Dim cc As Range, c As Range
Dim dic As Object
Dim i As Long, tmp

Set cc = Range("b2:n10").Columns

Set dic = CreateObject("scripting.dictionary")

For i = 1 To cc.Count Step 3
If WorksheetFunction.CountA(cc(i).Resize(, 3)) > 0 Then
For Each c In cc(i).Resize(, 3).Cells
If c.Interior.ColorIndex <> xlNone Then
dic(c.Interior.ColorIndex) = Empty
End If
Next
tmp = dic.Count
dic.RemoveAll
Else
tmp = "n"
End If
cc(i).Cells(1).Offset(cc.Rows.Count + 6, 1).Value = tmp
Next

End Sub

マナ

RIC63
01-05-2018, 12:27 PM
Hi mana,

great !! now it's perfect