Colorare le celle e contare le celle colorate

[ikwae]

Ciao a tutti ... Cerco il vostro prezioso e, insostituibile aiuto, per una possibile macro che colora le celle e infine conteggia le celle colorate di ogni colonna ... In allegato due fogli uno Sviluppo che è quello che devo usare normalmente e un foglio Pippo che, riporta uno spezzone del foglio Sviluppo, e visualizza una parte dimostrativa di quello che si vuole ottenere. Quindi ricapitolando la macro deve leggere tutta la colonna U fino alla fine dei dati partendo dalla cella U4 e leggere una o più istanze presenti nella cella e colorare la ruota alla dx di ogni riga. Se possibile mantenere i 4 colori per avere uno standard di un aiuto precedente. I colori si trovano in H5 e seguenti. Oppure 4 colori diversi possono andare bene lo stesso. Finito di colorare le celle la macro deve contare le celle colorate su ogni colonna e lo scrive in testa ad ogni colonna come visibile sul foglio Pippo. Non vorrei scrivere un “tema” e non sono per un eventuale sollecito ma ieri ho vinto un terno (37 39 53) con i tre ambi, che si porta dietro, sulla ruota di TO e un ulteriore ambo (46 71) sulla ruota di VE. Una misera vincita se non si fanno su ruota ma su tutte. Detto questo per dire che l’aiuto altro che prezioso è super prezioso e molto ma molto gradito ... Ringraziando anticipatamente tutti coloro che mi aiuteranno ... 73 ikwae

http://www.filedropper.com/pescacolorerete

[Anthony47]

Ho ignorato il foglio Pippo e lavorato su Sviluppo; da quello che ho intuito:

Codice: Seleziona tutto

Sub Not_a_Cavolo()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110005
Dim myDrum As String, I As Long, J As Long, myID As String
Dim myCols(0 To 6), myIDs(0 To 6), ECol As String, myC As Range
Dim mySplit, my1Split, myMatch, my2Match, LastR As Long, I0 As Long
'
myDrum = "AL3"      '<<< L'inizio delle intestazioni e delle estrazioni
myID = "H4"         '<<< L'inizio delle "celle dizionario", su 2 righe
ECol = "U"          '<<< La colonna da esaminare
'
Application.ScreenUpdating = False
LastR = Range(myDrum).Cells(1, 1).End(xlDown).Row
Range(Range(myDrum).Offset(1, 0), Range(myDrum).End(xlDown)).Resize(, 11).Interior.ColorIndex = xlNone
Range(myDrum).Offset(-1, 0).Resize(1, 11).ClearContents
'Dizionario di Id e colori:
For I = 0 To 6 Step 2
    myIDs(I) = Range(myID).Offset(0, I)
    myCols(I) = Range(myID).Offset(1, I).Interior.Color
Next I
I0 = Range(myDrum).Row + 1
'Scan colonna U:
For I = I0 To LastR
    If Cells(I, ECol) <> "" Then
        'Gruppi Risultato-Ruota:
        mySplit = Split(Cells(I, ECol) & " ", " ", , vbTextCompare)
        'Per ogni gruppo:
        For J = 0 To UBound(mySplit)
            'Elementi Risultato /Ruota, cerca e gestisci:
            my1Split = Split(mySplit(J), "-", , vbTextCompare)
            If UBound(my1Split) > 0 Then
                myMatch = Application.Match(my1Split(0), myIDs, False)
                my2Match = Application.Match(my1Split(1), Range(myDrum).Resize(1, 11), False)
                    If Not IsError(myMatch) And Not IsError(my2Match) Then
                        Range(myDrum).Offset(1 + I - I0, my2Match - 1).Interior.Color = myCols(myMatch - 1)
                        Range(myDrum).Offset(-1, my2Match - 1).Value = Range(myDrum).Cells(1, 1).Offset(-1, my2Match - 1).Value + 1
                    End If
            End If
        Next J
    End If
Next I
Application.ScreenUpdating = True
MsgBox ("Completato...")
End Sub

Se quanto proposto non c'entra niente allora tieni presente che tu questo schema lo sogni anche di notte; noi lo vediamo ogni tanto ma ogni volta e' come se fosse la prima volta, quindi un minimo di descrizione di quel che cerchi non e' solo desiderabile, ma "alquanto utile".

Ciao

[ikwae]

Gentilissimo Anthony47 innanzi tutto grazie per la risposta e della macro. Leggo che hai ignorato il foglio Pippo e di conseguenza ho applicato la tua macro e fa il totale dei colori nelle colonne AL2:AV2. Ma questa informazione è molto utile purtroppo l’avevo già il totale che l’ho “estrapolato” da un tuo precedente aiuto. La macro dovrebbe leggere, una o più voci, che sono nella colonna U a partire da U4:U(end) e colorare le ruote, su ogni riga della voce, a partire da W4:AG(end). I 4 colori sono in H5 e seguenti se si riesce a tenere questi colori, per uno standard di aiuto precedente, oppure altri 4 colori diversi vanno bene lo stesso. Finito di colorare le ruote la macro dovrebbe contare i colori di ogni colonna e scrivere il totale in testa alla colonna stessa a partire da W1:AG1... Ringraziandoti anticipatamente se riesci a trovare del tempo per modificare la macro... Penso di aver capito la discrezione di “alquanto utile” ....
Cordialmente ikwae

[Anthony47]

Quindi i dati da "lavorare" sono quelli su foglio Pippo? Nel qual caso:

Codice: Seleziona tutto

Sub Pippo_a_Cavolo()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110005
Dim myDrum As String, I As Long, J As Long, myID As String
Dim myCols(0 To 6), myIDs(0 To 6), ECol As String, myC As Range
Dim mySplit, my1Split, myMatch, my2Match, LastR As Long, I0 As Long
Dim mIDC As Long
'
myDrum = "W4"      '<<< L'inizio delle intestazioni e delle estrazioni
myID = "H4"         '<<< L'inizio delle "celle dizionario", su 2 righe
ECol = "U"          '<<< La colonna da esaminare
'
''Application.ScreenUpdating = False
LastR = Range(myDrum).End(xlDown).Row
Range(Range(myDrum).Offset(0, 0), Range(myDrum).End(xlDown)).Resize(, 11).Interior.ColorIndex = xlNone
mIDC = Range(myDrum).Column
Cells(1, mIDC).Resize(1, 11).ClearContents
'Dizionario di Id e colori:
For I = 0 To 6 Step 2
    myIDs(I) = Range(myID).Offset(0, I)
    myCols(I) = Range(myID).Offset(1, I).Interior.Color
Next I
I0 = Range(myDrum).Row '+ 1
'Scan colonna U:
For I = I0 To LastR
    If Cells(I, ECol) <> "" Then
        'Gruppi Risultato-Ruota:
        mySplit = Split(Cells(I, ECol) & " ", " ", , vbTextCompare)
        'Per ogni gruppo:
        For J = 0 To UBound(mySplit)
            'Elementi Risultato /Ruota, cerca e gestisci:
            my1Split = Split(mySplit(J), "-", , vbTextCompare)
            If UBound(my1Split) > 0 Then
                myMatch = Application.Match(my1Split(0), myIDs, False)
                my2Match = Application.Match(my1Split(1), Cells(I, mIDC).Resize(1, 11), False)
                    If Not IsError(myMatch) And Not IsError(my2Match) Then
                        Range(myDrum).Offset(I - I0, my2Match - 1).Interior.Color = myCols(myMatch - 1)
                        Cells(1, mIDC + my2Match - 1).Value = Cells(1, mIDC + my2Match - 1).Value + 1
                    End If
            End If
        Next J
    End If
Next I
Application.ScreenUpdating = True
MsgBox ("Completato...")
End Sub

Ciao

[ikwae]

Gentilissimo Anthony47 ho scaricato la macro e con un archivio “ridotto” da i risultati voluti, è molto veloce su 34 mila righe è istantanea ... Si riescono a vedere i numeri in testa alle colonne che aumentano ma proprio per un istante... Grazie anche per i colori che sono quelli proposti. Sta già lavorando nel “contenitore” delle 11 colonne in H ... Grazie ancora per il tuo tempo che mi hai dedicato. Cordialmente ikwae...

[ikwae]

Gentilissimo Anthony ... riapro questo post in quanto mi servono ancora dati per poter completare e, si spera, chiudere la situazione Province ... Vorrei, se possibile, una modifica alla macro (Sub Pippo_a_Cavolo) per scrivere in tabella quanti colori cadauno hanno preso le Province... Mi spiego meglio il W1-X1 ---- fino a AG1 c’è il totale dei colori che ogni colonna ha. Vorrei, aggiungo ancora se possibile, da ogni colonna sapere quanti colori ha una determinata Provincia e scriverli nella Tabella (C4:M14) ...

Altra indicazione di info; se in colonna W ci sono 26 colori(dato in W1)
Quanti dei 26 colori ha la Provincia di BA e scriverli in C4...
Quanti dei 26 colori ha la Provincia di CA e scriverli in C5...
Quanti dei 26 colori ha la Provincia di FI e scriverli in C6... ecc.. ecc.. fino alla cella C14 della RN

Poi si passa alla colonna X che ci sono 23 colori(dato in X2)
Quanti dei 23 colori ha la Provincia di BA e scriverli in D4...
Quanti dei 23 colori ha la Provincia di CA e scriverli in D5...
Quanti dei 23 colori ha la Provincia di FI e scriverli in D6... ecc.. ecc.. fino alla cella D14 della RN Ecc. Ecc.. E così per tutte le altre Province di ogni colonna fino alla AG ...

Spero di essermi spiegato(dato che ho tante lacune in merito) ... E’ poco probabile, che con una semplice modifica, aggiungere tutti questi dati penso che si debba riscrivere il codice di sana pianta e quindi, ti chiedo un ulteriore aiuto, di mettere nel codice anche i colori “celle dizionario” che io ho spostato, per ovvi motivi, da H4 in D1 ... Te lo chiedo, dato che non danno fastidio dove sono, per un semplice motivo ogni qualvolta che apro un foglio nuovo la macro non va e dopo varie prove mi devo ricordare che devo aggiungere a mano i colori altrimenti la Sub Pippo_a_Cavolo non va proprio quindi devo inserire il tutto ogni volta... è alquanto fastidioso non tanto nell’aggiunta ma quanto a ricordarsi il range e i colori o dove andarli a reperire per copiare ...

Ricapitolando
1) agglomerare nel codice i colori che nel codice riportano il nome di “celle dizionario”
2)scansionare una colonna alla volta e scrivere i vari colori che sono di ogni Provincia nella tabella.
In allegato un foglio Sviluppo per eventuale prove e range...

Ringraziandoti, oltre misura che non è mai troppo, per questo ulteriore aiuto. Cordialmente 73 ikwae
http://www.filedropper.com/helpcoloricadprovincerete

[Anthony47]

Probabilmente:

Codice: Seleziona tutto

Sub Pippo_a_Cavolo2()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110005
Dim myDrum As String, I As Long, J As Long, myID As String
Dim myCols(0 To 6), myIDs(0 To 6), ECol As String, myC As Range
Dim mySplit, my1Split, myMatch, my2Match, LastR As Long, I0 As Long
Dim mIDC As Long, Tab0 As String
'
myDrum = "W4"      '<<< L'inizio delle intestazioni e delle estrazioni
'myID = "H4"         '<<< L'inizio delle "celle dizionario", su 2 righe
 myID = "D1"
ECol = "U"          '<<< La colonna da esaminare
Tab0 = "C4"           '<<< L'inizio della tabella da compilare
'
''Application.ScreenUpdating = False
LastR = Range(myDrum).End(xlDown).Row
Range(Range(myDrum).Offset(0, 0), Range(myDrum).End(xlDown)).Resize(, 11).Interior.ColorIndex = xlNone
mIDC = Range(myDrum).Column
Cells(1, mIDC).Resize(1, 11).ClearContents
'Dizionario di Id e colori:
For I = 0 To 6 Step 2
    myIDs(I) = Range(myID).Offset(0, I)
    myCols(I) = Range(myID).Offset(1, I).Interior.Color
Next I
I0 = Range(myDrum).Row '+ 1
'Scan colonna U:
For I = I0 To LastR
    If Cells(I, ECol) <> "" Then
        'Gruppi Risultato-Ruota:
        mySplit = Split(Cells(I, ECol) & " ", " ", , vbTextCompare)
        'Per ogni gruppo:
        For J = 0 To UBound(mySplit)
            'Elementi Risultato /Ruota, cerca e gestisci:
            my1Split = Split(mySplit(J), "-", , vbTextCompare)
            If UBound(my1Split) > 0 Then
                myMatch = Application.Match(my1Split(0), myIDs, False)
                my2Match = Application.Match(my1Split(1), Cells(I, mIDC).Resize(1, 11), False)
                    If Not IsError(myMatch) And Not IsError(my2Match) Then
                        Range(myDrum).Offset(I - I0, my2Match - 1).Interior.Color = myCols(myMatch - 1)
                        Cells(1, mIDC + my2Match - 1).Value = Cells(1, mIDC + my2Match - 1).Value + 1
                        Range(Tab0).Offset(Application.Match(my1Split(1), Range(Tab0).Offset(0, -1).Resize(12, 1), False) - 1, my2Match - 1).Value = _
                          Range(Tab0).Offset(Application.Match(my1Split(1), Range(Tab0).Offset(0, -1).Resize(12, 1), False) - 1, my2Match - 1).Value + 1
                    End If
            End If
        Next J
    End If
Next I
Application.ScreenUpdating = True
'MsgBox ("Completato...")
End Sub


Ho cioe' aggiunto la riga Tab0 = "C4" in testa e poi un'altra istruzione (su due righe) all'interno della If Not IsError(myMatch) And Not IsError(my2Match) Then / End If

Ciao

[ikwae]

Gentilissimo Anthony ... ho provato la tua macro e funge bene ma c'è un piccolo neo superabile facilmente ... Se si clicca più volte,sul tasto che lancia la nuova macro, sulla tabella somma i numeri con quelli precedenti ma nulla di eclatante metterò in testa alla macro un pulisci tabella.

Gentilissimo Anthony... ti chiedo un ulteriore aiuto, di mettere nel codice anche i colori “celle dizionario” che io ho spostato.... Te lo chiedo, per un semplice motivo ogni qualvolta che apro un foglio nuovo la macro non va e dopo varie prove mi devo ricordare che devo aggiungere a mano i colori altrimenti la Sub Pippo_a_Cavolo non va proprio quindi devo inserire il tutto ogni volta... è alquanto fastidioso non tanto nell’aggiunta ma quanto a ricordarsi il range e i colori o dove andarli a reperire per copiare ...

Se per questo secondo aiuto non si riesce a fare nulla sono contento lo stesso ... Quindi un grosso grazie completo e, non parziale, per il tuo gradito e prezioso tempo che mi hai dedicato ancora mille grazie ... Cordialmente 73 ikwae

[Anthony47]

Se ho capito quel che dici, togli nella Sub Pippo_a_Cavolo2 tutto il ciclo For I = 0 To 6 Step 2 /Next I e inserisci invece

Codice: Seleziona tutto

myIDs = Array("A", 1, "T", 2, "Q", 3, "C")
myCOLs = Array(RGB(50, 200, 250), 222, RGB(250, 190, 140), 222, RGB(200, 150, 250), 222, RGB(190, 215, 155))

Parallelamente devi eliminare la riga Dim myCols(0 To 6), myIDs(0 To 6), ECol As String, myC As Range e inserire invece

Codice: Seleziona tutto

Dim myCOLs, myIDs, ECol As String, myC As Range

Ciao

[ikwae]

Gentilissimo Anthony... Ho inserito le tue istruzioni dove richiesto e funge bene come da richiesta .... Grazie per il tempo e, il doppio impegno che mi hai dedicato ... Cordialmente 73 ikwae