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
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
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
thanks again for your support
sincerely
riccardo
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.