Conta le celle colorate / migliore peggiore

[raimea]

ciao
nel foglio classificaXgg
(tramite macro o formula)

vorrei contare quante volte ogni nominativo
e' stato il migliore in riga 11 F11:N11
il peggiore in riga 12 F12:N12

il conteggio si puo ottenere

1_contando il colore in ogni colonna
verde x il migliore poi rosso=peggiore

2_x ogni riga da riga 14 col F:N
il migliare avra' il numero piu alto x riga
il peggiore avra' il numero piu basso per riga

spero di essermi spiegato,

per i numeri inseriti ho fatto i conteggi manualmente
per dare un indicazione.

allego il file

https://www.dropbox.com/scl/fi/50lalqiqa4r3kqt2k55b5/conta_colorate.xlsm?rlkey=1vhxfkc5qzwsenr2s20fz8vfk&st=5rul6b6m&dl=0

ciao

NB
le celle vengono colorate da vba
NON da formattaz condizionale

[Raffaele53]

Da provare

Codice: Seleziona tutto

Sub colora()
Dim r As Integer, i As Integer, j As Integer, minimo As Integer, massimo As Integer
Range("F14:n300").Interior.Pattern = xlNone
Range("F11:N12") = ""
r = Range("F13:F1000").Find("-", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
For i = 14 To r
   minimo = Application.Min(Range("F" & i & ":N" & i))
   massimo = Application.Max(Range("F" & i & ":N" & i))
    For j = 6 To 14  ' 6 col F 14 col N
        If Cells(i, j) = minimo Then Cells(i, j).Interior.Color = vbRed: Cells(12, j) = Cells(12, j) + 1
        If Cells(i, j) = massimo Then Cells(i, j).Interior.Color = vbGreen: Cells(11, j) = Cells(11, j) + 1
    Next j
Next i
End Sub

[raimea]

Ciao Raffaele

Non funzionava, ma ho trovato l 'inghippo....

ho solo modificato il modo di calcolare il valore di >> r

Codice: Seleziona tutto

Sub colora2()
Dim r As Integer, i As Integer, j As Integer, minimo As Integer, massimo As Integer
Range("F14:n300").Interior.Pattern = xlNone
Range("F11:N12") = ""

'r = Range("F13:F1000").Find("-", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row  '<<< old
r = Range("E" & Rows.Count).End(xlUp).Row                                                 ' <<< nws

For i = 14 To r

   minimo = Application.Min(Range("F" & i & ":N" & i))
   massimo = Application.Max(Range("F" & i & ":N" & i))

con la riga nws tutto ok

quindi....


GRAZIE raffaele 53

ciao

[Raffaele53]

La Tua fa lavorare per 201 righe, questa solo le righe delle formule valorizzate (colora e conta)
r = Range("F13:F1000").Find("-", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Row

Modifica pure questa >>>Range("F11:N12") = 0

[raimea]

ciao

La Tua fa lavorare per 201 righe, questa solo le formule valorizzate
r = Range("F13:F1000").Find("-", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Row

ma se provi ad inserire il codice nel file allegato
mi elabora solo le prime 2 righe la riga 14 e la riga 15

ecco perche' ho provato a smanettare...

sempre smanettando
sono riuscito far funzionare tuo >> r
togliendo il - nelle apici e mettendo un -1 alla fine

Codice: Seleziona tutto

r = Range("F13:F1000").Find("", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row - 1

////////////////////////////
colgo l 'occasione ....

con minimo e massimo min colora il numero min e il max

se volessi colorare di giallo, anche il PENULTIMO numero ?

come lo si scrive in vba il penultimo ?

ciao

[Raffaele53]

Funzionava benissimo col "-", almeno sul files che Tu hai allegato. Questo colora pure il giallo ma non hai detto se dovevo contarlo assieme all'ultimo.

Codice: Seleziona tutto

Sub colora()
Dim r As Integer, i As Integer, j As Integer, x As Integer, minimo As Integer, massimo As Integer, P_Ult As Integer
Range("F14:N300").Interior.Pattern = xlNone
Range("F11:N12") = 0
r = Range("F13:F1000").Find("-", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Row
For i = 14 To r
   minimo = Application.Min(Range("F" & i & ":N" & i))
   massimo = Application.Max(Range("F" & i & ":N" & i))
   P_Ult = massimo - 1
    For x = massimo - 1 To minimo + 1  Step -1
        If Application.CountIf(Range("F" & i & ":N" & i), x) > 0 Then P_Ult = x: Exit For
    Next
    For j = 6 To 14  ' 6 col F 14 col N
        If Cells(i, j) = minimo Then Cells(i, j).Interior.Color = vbRed: Cells(12, j) = Cells(12, j) + 1
        If Cells(i, j) = P_Ult Then Cells(i, j).Interior.Color = vbYellow: Cells(11, j) = Cells(11, j) + 1
        If Cells(i, j) = massimo Then Cells(i, j).Interior.Color = vbGreen: Cells(11, j) = Cells(11, j) + 1
    Next j
Next i
End Sub

[raimea]

ciao
ho provato la macro per colorare il PENULTIMO

non hai detto se dovevo contarlo assieme all'ultimo.

i PENULTIMI NON devono essere contati x ora
ma solo Colorati di Giallo.

ma in realta' mi colora il migliore meno-1
io mi riferivo al peggiore+1


per farmi capire allego l immagine
di come dovrebbe essere

ES
in riga4 il num 3 in riga 7 il num 7
in riga 11 il num 10 ecc...

-Funzionava benissimo col "-", almeno sul files che Tu hai allegato.

azz misteri a me colorava solo riga 14 e 15 !

ciao

[Raffaele53]

Peggiore+1 senza contarli

Codice: Seleziona tutto

Sub colora()
Dim r As Integer, i As Integer, j As Integer, x As Integer, minimo As Integer, massimo As Integer, P_Ult As Integer
Range("F14:N300").Interior.Pattern = xlNone
Range("F11:N12") = 0
r = Range("F13:F1000").Find("-", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Row
For i = 14 To r
   minimo = Application.Min(Range("F" & i & ":N" & i))
   massimo = Application.Max(Range("F" & i & ":N" & i))
   P_Ult = minimo + 1
    For x = minimo + 1 To massimo - 1
        If Application.CountIf(Range("F" & i & ":N" & i), x) > 0 Then P_Ult = x: Exit For
    Next
    For j = 6 To 14  ' 6 col F 14 col N
        If Cells(i, j) = minimo Then Cells(i, j).Interior.Color = vbRed: Cells(12, j) = Cells(12, j) + 1
        If Cells(i, j) = P_Ult Then Cells(i, j).Interior.Color = vbYellow 'non si contano
        If Cells(i, j) = massimo Then Cells(i, j).Interior.Color = vbGreen: Cells(11, j) = Cells(11, j) + 1
    Next j
Next i
End Sub


[raimea]

tutto ok

ringrazio raffaele53

per la pazienza e disponibilità dimostrata

grazie