Count_Colours_Not_Duplicate

[RIC63]

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]

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]

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]

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]

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]

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]

Hi mana,

great !! now it's perfect
thanks again for your support
sincerely

riccardo