Consulting

Results 1 to 7 of 7

Thread: Count_Colours_Not_Duplicate

  1. #1
    VBAX Regular
    Joined
    Jan 2015
    Posts
    46
    Location

    Count_Colours_Not_Duplicate

    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
    Attached Images Attached Images

  2. #2
    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

  3. #3
    VBAX Regular
    Joined
    Jan 2015
    Posts
    46
    Location
    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
    Last edited by Aussiebear; 12-31-2017 at 01:40 PM. Reason: Wrapped submitted code with tags

  4. #4
    VBAX Expert
    Joined
    Sep 2016
    Posts
    779
    Location
    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

    マナ

  5. #5
    VBAX Regular
    Joined
    Jan 2015
    Posts
    46
    Location
    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

  6. #6
    VBAX Expert
    Joined
    Sep 2016
    Posts
    779
    Location
    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
    マナ
    Last edited by mana; 01-01-2018 at 05:11 PM.

  7. #7
    VBAX Regular
    Joined
    Jan 2015
    Posts
    46
    Location
    Hi mana,

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

    riccardo

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •