VERIFICA VFRAC su TURNI

Hai un problema con Excel?

Nuova discussione

VERIFICA V.FRAC su TURNI
di Lisa B. data: 17/03/2015 00:36:22
Discussione DEDICATA in quanto è INTERAMENTE opera tua...

Io ho adattato il tuo VBA al foglio "originale".

In primis rispettando i range originali e funzionava alla grande... poi come vedrai nell'esempio, estendendo la verifica a tutte le righe dei turni.

Le righe 14, 15, 16 35, 36, 37, 38 e 39 sono e resteranno vuote... sono "cornici" diciamo...

Ho testato il VBA esteso e funziona alla grande... funziona in ogni sua parte se non fosse per quelle 2 stringhe arancioni che fa... sarebbe perfetto...

Ho tentato di capire da cosa fossero generate ma non ci sono riuscita...

Comunque... la cosa fondamentale.... ho visto che FUNZIONA anche ESTESO

Option Explicit

Sub colorize()
Dim my_range As Range, my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range
Dim rip_cell As Range, rip As Integer

    Application.ScreenUpdating = False
    
    'normalizza l'intera tabella, bordi compresi
    set_color Range("T12:AK47"), xlAutomatic, 2, True, True
    
    'considera alcune condizioni di ALLERTA (celle in ARANCIONE)
    '-----------------------------------------------------------
    Set my_range = Range("U13:AA46,AD13:AJ46")   'prende in esame ognuno dei due quadranti setitmanali
    For Each my_row In my_range.Rows        'scorre riga per riga
        'non possono esserci più di due riposi infrasettimanali in una settimana
        '(non si applica se uno dei riposi è festivo, RFI)
         If (count_of(my_row, "R") > 2) And (count_of(my_row, "RFI") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then
                    set_color cell, xlAutomatic, 46, True, True
                End If
            Next
        End If
        
        'non può esserci solo un riposo in una settimana a meno che in settimana non ci sia *S o *F
        '(tutta la settimana diventa ARANCIONE, tranne la cella con il codice di riposo)
        If (count_of(my_row, "R") = 1) And (count_of(my_row, "S") + count_of(my_row, "F") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then set_color cell, xlAutomatic, 46, True, True
            Next
        End If
    Next
    
    'non possono esserci comunque mai 7 turni consecutivi, contando anche le celle del secondo quadrante
    '(salta la regola con *S, *F o RFI)
    Set my_range = Range("U13:AJ46")
    For Each my_row In my_range.Rows        'scorre riga per riga dei due quadranti unificati
        col = 0: rip = 0
        For Each cell In my_row.Cells
            col = col + 1
            If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                If cell = "RO" Or cell = "RC" Then
                    rip = 0
                    Set rip_cell = cell
                Else
                    rip = rip + 1
                End If
                If rip > 6 Then     'non possono esserci più di 6 turni consecutivi, colora di ARANCIONE dall'ultimo riposo fino al prossimo
                    set_color Range(Cells(rip_cell.Row, rip_cell.Column + 1), Cells(rip_cell.Row, rip_cell.Column + rip + IIf(col > 9, 2, 0))), xlAutomatic, 46, True, True
                    'rip = 0
                    'Exit For
                End If
            End If
        Next
    Next
    
    'applica le regole normali, casi speciali e condizioni di ERRORE
    Call apply_rules(Range("U13:AJ46"))
         
    Range("AK12:AK47, AB13:AC46").Interior.ColorIndex = 2
    Application.ScreenUpdating = True
    
    Range("U13:AJ46").FormatConditions.Delete
    Range("AB13:AC46").Font.italic = False
    
    MsgBox "VERIFICA ULTIMATA"
    
End Sub


Private Sub apply_rules(r As Range)
Dim my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range

'applica le regole normali

    For Each my_row In r.Rows        'scorre riga per riga
        col = 0
        For Each cell In my_row.Cells                  'scorre ogni riga dalla prima alla terz'ultima cella e considera cella per cella
            col = col + 1
            
            If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                
                Select Case my_row.Cells(col)
                Case "C+", "C**", "CS", "C+S", "C*S", "C**S", "CF", "C+F", "C*F", "C**F"
                    set_color cell, 2, 3, True, False
                    
                Case "1+", "1S", "1+S", "1*S", "1**S", "1F", "1+F", "1*F", "1**F"
                    set_color cell, 2, 3, True, False
                    
                Case "2+", "2S", "2+S", "2*S", "2**S", "2F", "2+F", "2*F", "2**F"
                    set_color cell, 2, 3, True, False
                    
                Case "3+", "3**", "3S", "3+S", "3*S", "3**S", "3F", "3+F", "3*F", "3**F"
                    set_color cell, 2, 3, True, False
                    
                Case "RO", "RC", "RFI":
                    set_color cell, 3, 36, True, False
                
                Case "F", "DISP":
                    set_color cell, 3, 34, True, False
                    
                Case "M":
                    set_color cell, 2, 30, True, False
                
                Case "DS":
                    set_color cell, 2, 32, True, False
                
                End Select
                
                Set next_cell = cell.Offset(, 1)
                Set next_next_cell = cell.Offset(, 2)
                
                'se siamo nella penultima colonna del primo quadrante:
                'la cella successiva è stata impostata, ma la cella dopo è la prima del secondo quadrante
                If col = 6 Then
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'se siamo nell'ultima colonna del primo quadrante
                'la cella successiva è la prima del secondo quadrante, quella dopo ancora è la seconda
                If col = 7 Then
                    Set next_cell = cell.Offset(, 3)
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'controlla condizioni di ERRORE (in ROSSO)
                '-----------------------------------------
                'ignora condizioni di errore legate al 3 se si esamina l'ultima colonna del secondo quadrante
                If col < 16 Then
                    'altrimenti considera alcune condizioni di ERRORE
                    Select Case Left(cell, 1)
                    Case "3"
                        'un 3 non può essere seguito da un 2 o da un 1
                        If next_cell Like "2*" Or next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                    
                        'un 3 deve essere seguito da due celle R* oppure da un altro 3
                        If Left(next_cell, 1) Like "[Rr]" And Not (Left(next_next_cell, 1) Like "[Rr]") Then
                            set_color next_next_cell, xlAutomatic, 3, True, True
                        End If
                        
                    Case "2"
                        'un 2 non può essere seguito da un 1
                        If next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                        
                    End Select
                End If
                
            End If
        Next
    Next



End Sub


Private Sub set_color(this_cell As Range, foreground As Integer, background As Integer, bold, italic)
    With this_cell
        With .Font
            .bold = True
            .italic = True
            .ColorIndex = foreground
        End With
        If this_cell.Cells.Count = 1 Then
            If .Interior.ColorIndex <> 46 Then
                .Interior.ColorIndex = background
            End If
        Else
            .Interior.ColorIndex = background
        End If
    End With
    
End Sub



Private Function count_of(ByVal r As Range, what As String)
Dim vect() As Variant, v As Variant, i As Integer, s As String
    
    ReDim vect(1 To r.Cells.Count)
    For Each v In r.Cells
        i = i + 1
        vect(i) = v
    Next
    s = Join(vect, vbNullChar) & vbNullChar
    count_of = Len(Replace(s, what, what & "*")) - Len(s)
    
End Function

Regolamento!
di Mauro data: 17/03/2015 06:00:07
Vi invito a non perdere di vista le linee guida di questo forum: Questo Forum NON E' UN SERVIZIO DI CONSULENZA GRATUITO, ma un punto dove chiunque può condividere le proprie esperienze e quindi crescere ed aiutare a crescere
di Lisa B. data: 17/03/2015 08:56:45
Nooo Mauro... Non fraintendere....

Non ho voluto dedicare il nuovo messaggio a V.Frac x chirdere solo a lui un aiuto...

L'ho fatto per dargli merito del fatto che il VBA creato esiste per merito suo....

Ovviamente chiunque è libero di intervenire....

Perdonami se sono stata poco chiara
di Mauro data: 17/03/2015 09:00:32
Ok Lisa, grazie per il chiarimento!
di Lisa B. data: 17/03/2015 12:43:49
Era doveroso Mauro.....
di Vecchio Frac data: 17/03/2015 18:38:17
A difesa di entrambi, aggiungo solo che ho seguito da vicino un lavoro che poi è divenuto abbastanza complesso nell'insieme, e come si è visto dalla discussione principale la strada per arrivare a questo risultato è stata lunga :) Quindi chiunque si avvicinasse al lavoro potrebbe sentirsi non invogliato a rileggersi tutti i 50 e passa messaggi nè a studiarsi il codice prodotto.
Comunque vedrò il risultato finale che Lisa ha allegato per vedere se riesco a risolvere il problema delle righe superflue arancioni (non sarà possibile, lo so già, per come ho impostato la macro... ma magari un correttivo si trova).

Come Moderatore, richiamo anch'io sul fatto che il titolo dato alla discussione è improprio sia perchè si rivolge a un utente specifico sia perchè non permette una costruttiva ricerca futura.
di Lisa B. data: 17/03/2015 19:40:43
Sono desolata e chiedo scusa... Volevo con il mio gesto dare merito al tuo lavoro ifnorando ciò che giustamente gai detto.

Chiedo ancora scusa. Allo stesso modo non me la sento di chiederti di rivedere tutto il VBA... Sei stato gentilissimo a fare ciò che hai fatto e non voglio chiederti di più. Se era una cosa "veloce" ok... Ma da quanto ho capito è da rivedere il codice quindi...

Lasciamo perdere... Grazie di vero cuore per ciò che hai fatto
di Mauro data: 17/03/2015 20:05:15
Non serve scusarsi, non è successo nulla di grave ho solo puntualizzato un aspetto a cui tengo particolarmente e non volevo rimproverare nessuno. Non credo servano altre puntualizzazione in merito. Un saluto a entrambi.

di Vecchio Frac data: 17/03/2015 20:49:33
Guarda Lisa, sai la cosa più veloce che mi viene in mente di farti fare, se lo schema del foglio è questo, con dodici righe vuote sopra, e il range fino a AK47, per eliminare quelle fastidiose righe arancioni spurie è il seguente:
normalizziamo lo sfondo impostandolo a None relativamente all'area che sta fuori dai due quadranti!

Ti riporto le ultime righe della sub principale con evidenziata la riga aggiunta.
Se domani mi avanza tempo (oggi è stata una giornataccia) provo a sviluppare un commento più umano al (lungo) codice.

p.s. non scusarti... so che hai apprezzato questo lavoro :)
patron Mauro e io abbiamo un ruolo da mantenere :P

    Range("AK12:AK47, AB13:AC46").Interior.ColorIndex = 2
    Range("AL12:AZ50").Interior.ColorIndex = xlNone        '<<<<<< normalizza l'area esterna ai quadranti
    Application.ScreenUpdating = True
    
    Range("U13:AJ46").FormatConditions.Delete
    Range("AB13:AC46").Font.italic = False
    
    MsgBox "VERIFICA ULTIMATA"

di Lisa B. data: 18/03/2015 11:33:33
Grazie V.Frac... Come soluzione potrebbe anche andarmi bene... rimane solo un quadrante arancione... e... potrei farmene anche una ragione
di Vecchio Frac data: 18/03/2015 14:01:03
cit. "rimane solo un quadrante arancione"
---> Davvero? un intero quadrante settimanale arancione? non dovrebbe essere così...
A meno che per quadrante tu non intenda la cella AJ34 che in effetti rimane arancione (io per quadrante intendo l'intero sistema settimanale).

di Vecchio Frac data: 18/03/2015 14:10:59
Lisa ci siamo, ho trovato l'inghippo
Sai qual era il problema? che come hai detto tu nel primo post "Le righe 14, 15, 16 35, 36, 37, 38 e 39 sono e resteranno vuote... sono "cornici" diciamo... " ci sono delle righe di cornice che in qualche modo vengono considerate, se più di sei consecutive, un errore da far evidenziare in arancione le successive.
Teniamone quindi conto e nella routine che verifica i sette turni consecutivi evitiamo il controllo sulle celle vuote (prometti che quelle celle resteranno vuote!!).
Ti riallego l'intero codice che sostituisce integralmente i precedenti.
Fai alcune prove e dimmi come va... nel frattempo vedo di mettere giù un commento al codice.

Option Explicit

Sub colorize()
Dim my_range As Range, my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range
Dim rip_cell As Range, rip As Integer

    Application.ScreenUpdating = False
    
    'normalizza l'intera tabella, bordi compresi
    set_color Range("T12:AK47"), xlAutomatic, 2, True, True
    
    'considera alcune condizioni di ALLERTA (celle in ARANCIONE)
    '-----------------------------------------------------------
    Set my_range = Range("U13:AA46,AD13:AJ46")   'prende in esame ognuno dei due quadranti setitmanali
    For Each my_row In my_range.Rows        'scorre riga per riga
        'non possono esserci più di due riposi infrasettimanali in una settimana
        '(non si applica se uno dei riposi è festivo, RFI)
         If (count_of(my_row, "R") > 2) And (count_of(my_row, "RFI") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then
                    set_color cell, xlAutomatic, 46, True, True
                End If
            Next
        End If
        
        'non può esserci solo un riposo in una settimana a meno che in settimana non ci sia *S o *F
        '(tutta la settimana diventa ARANCIONE, tranne la cella con il codice di riposo)
        If (count_of(my_row, "R") = 1) And (count_of(my_row, "S") + count_of(my_row, "F") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then set_color cell, xlAutomatic, 46, True, True
            Next
        End If
    Next
    
    'non possono esserci comunque mai 7 turni consecutivi, contando anche le celle del secondo quadrante
    '(salta la regola con *S, *F o RFI)
    Set my_range = Range("U13:AJ46")
    For Each my_row In my_range.Rows        'scorre riga per riga dei due quadranti unificati
        col = 0: rip = 0
        For Each cell In my_row.Cells
            If Trim(cell) <> "" Then
                col = col + 1
                If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                    If cell = "RO" Or cell = "RC" Then
                        rip = 0
                        Set rip_cell = cell
                    Else
                        rip = rip + 1
                    End If
                    If rip > 6 Then     'non possono esserci più di 6 turni consecutivi, colora di ARANCIONE dall'ultimo riposo fino al prossimo
                        set_color Range(Cells(rip_cell.Row, rip_cell.Column + 1), Cells(rip_cell.Row, rip_cell.Column + rip + IIf(col > 9, 2, 0))), xlAutomatic, 46, True, True
                    End If
                End If
            End If
        Next
    Next
    
    'applica le regole normali, casi speciali e condizioni di ERRORE
    Call apply_rules(Range("U13:AJ46"))
         
    Range("AK12:AK47, AB13:AC46").Interior.ColorIndex = 2
    Application.ScreenUpdating = True
    
    Range("U13:AJ46").FormatConditions.Delete
    Range("AB13:AC46").Font.italic = False
    
    MsgBox "VERIFICA ULTIMATA"
    
End Sub


Private Sub apply_rules(r As Range)
Dim my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range

'applica le regole normali

    For Each my_row In r.Rows        'scorre riga per riga
        col = 0
        For Each cell In my_row.Cells                  'scorre ogni riga dalla prima alla terz'ultima cella e considera cella per cella
            col = col + 1
            
            If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                
                Select Case my_row.Cells(col)
                Case "C+", "C**", "CS", "C+S", "C*S", "C**S", "CF", "C+F", "C*F", "C**F"
                    set_color cell, 2, 3, True, False
                    
                Case "1+", "1S", "1+S", "1*S", "1**S", "1F", "1+F", "1*F", "1**F"
                    set_color cell, 2, 3, True, False
                    
                Case "2+", "2S", "2+S", "2*S", "2**S", "2F", "2+F", "2*F", "2**F"
                    set_color cell, 2, 3, True, False
                    
                Case "3+", "3**", "3S", "3+S", "3*S", "3**S", "3F", "3+F", "3*F", "3**F"
                    set_color cell, 2, 3, True, False
                    
                Case "RO", "RC", "RFI":
                    set_color cell, 3, 36, True, False
                
                Case "F", "DISP":
                    set_color cell, 3, 34, True, False
                    
                Case "M":
                    set_color cell, 2, 30, True, False
                
                Case "DS":
                    set_color cell, 2, 32, True, False
                
                End Select
                
                Set next_cell = cell.Offset(, 1)
                Set next_next_cell = cell.Offset(, 2)
                
                'se siamo nella penultima colonna del primo quadrante:
                'la cella successiva è stata impostata, ma la cella dopo è la prima del secondo quadrante
                If col = 6 Then
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'se siamo nell'ultima colonna del primo quadrante
                'la cella successiva è la prima del secondo quadrante, quella dopo ancora è la seconda
                If col = 7 Then
                    Set next_cell = cell.Offset(, 3)
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'controlla condizioni di ERRORE (in ROSSO)
                '-----------------------------------------
                'ignora condizioni di errore legate al 3 se si esamina l'ultima colonna del secondo quadrante
                If col < 16 Then
                    'altrimenti considera alcune condizioni di ERRORE
                    Select Case Left(cell, 1)
                    Case "3"
                        'un 3 non può essere seguito da un 2 o da un 1
                        If next_cell Like "2*" Or next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                    
                        'un 3 deve essere seguito da due celle R* oppure da un altro 3
                        If Left(next_cell, 1) Like "[Rr]" And Not (Left(next_next_cell, 1) Like "[Rr]") Then
                            set_color next_next_cell, xlAutomatic, 3, True, True
                        End If
                        
                    Case "2"
                        'un 2 non può essere seguito da un 1
                        If next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                        
                    End Select
                End If
                
            End If
        Next
    Next

End Sub


Private Sub set_color(this_cell As Range, foreground As Integer, background As Integer, bold, italic)
    With this_cell
        With .Font
            .bold = True
            .italic = True
            .ColorIndex = foreground
        End With
        If this_cell.Cells.Count = 1 Then
            If .Interior.ColorIndex <> 46 Then
                .Interior.ColorIndex = background
            End If
        Else
            .Interior.ColorIndex = background
        End If
    End With
    
End Sub



Private Function count_of(ByVal r As Range, what As String)
Dim vect() As Variant, v As Variant, i As Integer, s As String
    
    ReDim vect(1 To r.Cells.Count)
    For Each v In r.Cells
        i = i + 1
        vect(i) = v
    Next
    s = Join(vect, vbNullChar) & vbNullChar
    count_of = Len(Replace(s, what, what & "*")) - Len(s)
    
End Function

di Lisa B. data: 18/03/2015 17:14:13
promesso che resteranno vuote...

Verifica fatta in modo superficiale e sembra tutto ok....

Nei prossimi giorni la esamino a fondo.

V.Frac... Ti devo una cena!!!!!!

Grazie davvero di ❤
di Vecchio Frac data: 18/03/2015 20:51:54
Non sono riuscito a preparare il commento al codice :(
Mi sa che mi sfuma la cena ;)
di Lisa B. data: 18/03/2015 23:01:44
Affatto V.Frac... sei una persona gentilissima e nulla è preteso... non ho nessuna fretta in quanto mai io riuscirei a fare un lavoro del genere e quindi ti sono e sarò grata anche se rispondessi una settimana x l'altra.

Ho una brutta notizia... l'ultima versione mi da un errore che la precedente non mi dava... e te l'ho evidenziato nell'allegato TURNI FULL.

Ripeto non ho fretta e nulla e preteso... hai tutto il tempo

UN'ABBRACCIO DI VERA GRATITUDINE!!!!!!!!!!!
di Lisa B. data: 18/03/2015 23:02:40
TURNI FULL 2 ....

di Vecchio Frac data: 19/03/2015 14:29:35
Ciao Lisa,
purtroppo i problemi si vedono solo con la sperimentazione. Non ho in effetti eseguito test completi con la casistica a disposizione.
Comunque il problema del codice precedente è che la parte che si occupa di contare i turni consecutivi esclude le celle vuote ma non le due colonne centrali tra i due quadranti settimanali; quindi ti propongo la modifica seguente (preferisco riallegare il codice completo).
Riportami eventuali altri errori... spero di no :)

Option Explicit

Sub colorize()
Dim my_range As Range, my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range
Dim rip_cell As Range, rip As Integer

    Application.ScreenUpdating = False
    
    'normalizza l'intera tabella, bordi compresi
    set_color Range("T12:AK47"), xlAutomatic, 2, True, True
    
    'considera alcune condizioni di ALLERTA (celle in ARANCIONE)
    '-----------------------------------------------------------
    Set my_range = Range("U13:AA46,AD13:AJ46")   'prende in esame ognuno dei due quadranti setitmanali
    For Each my_row In my_range.Rows        'scorre riga per riga
        'non possono esserci più di due riposi infrasettimanali in una settimana
        '(non si applica se uno dei riposi è festivo, RFI)
         If (count_of(my_row, "R") > 2) And (count_of(my_row, "RFI") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then
                    set_color cell, xlAutomatic, 46, True, True
                End If
            Next
        End If
        
        'non può esserci solo un riposo in una settimana a meno che in settimana non ci sia *S o *F
        '(tutta la settimana diventa ARANCIONE, tranne la cella con il codice di riposo)
        If (count_of(my_row, "R") = 1) And (count_of(my_row, "S") + count_of(my_row, "F") = 0) Then
            For Each cell In my_row.Cells
                If Not (Left(cell, 1) Like "[Rr]") Then set_color cell, xlAutomatic, 46, True, True
            Next
        End If
    Next
    
    'non possono esserci comunque mai 7 turni consecutivi, contando anche le celle del secondo quadrante
    '(salta la regola con *S, *F o RFI)
    Set my_range = Range("U13:AJ46")
    For Each my_row In my_range.Rows        'scorre riga per riga dei due quadranti unificati
        col = 0: rip = 0
        For Each cell In my_row.Cells
            col = col + 1
            If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                If Trim(cell) <> "" Then
                    If cell = "RO" Or cell = "RC" Then
                            rip = 0
                            Set rip_cell = cell
                        Else
                            rip = rip + 1
                    End If
                    If rip > 6 Then     'non possono esserci più di 6 turni consecutivi, colora di ARANCIONE dall'ultimo riposo fino al prossimo
                        set_color Range(Cells(rip_cell.Row, rip_cell.Column + 1), Cells(rip_cell.Row, rip_cell.Column + rip + IIf(col > 9, 2, 0))), xlAutomatic, 46, True, True
                    End If
                End If
            End If
        Next
    Next
    
    'applica le regole normali, casi speciali e condizioni di ERRORE
    Call apply_rules(Range("U13:AJ46"))
         
    Range("AK12:AK47, AB13:AC46").Interior.ColorIndex = 2
    Application.ScreenUpdating = True
    
    Range("U13:AJ46").FormatConditions.Delete
    Range("AB13:AC46").Font.italic = False
    
    MsgBox "VERIFICA ULTIMATA"
    
End Sub


Private Sub apply_rules(r As Range)
Dim my_row As Range, cell As Range, col As Integer
Dim next_cell As Range, next_next_cell As Range

'applica le regole normali

    For Each my_row In r.Rows        'scorre riga per riga
        col = 0
        For Each cell In my_row.Cells                  'scorre ogni riga dalla prima alla terz'ultima cella e considera cella per cella
            col = col + 1
            
            If col < 8 Or col > 9 Then      'salta le due colonne centrali (relativamente a my_range)
                
                Select Case my_row.Cells(col)
                Case "C+", "C**", "CS", "C+S", "C*S", "C**S", "CF", "C+F", "C*F", "C**F"
                    set_color cell, 2, 3, True, False
                    
                Case "1+", "1S", "1+S", "1*S", "1**S", "1F", "1+F", "1*F", "1**F"
                    set_color cell, 2, 3, True, False
                    
                Case "2+", "2S", "2+S", "2*S", "2**S", "2F", "2+F", "2*F", "2**F"
                    set_color cell, 2, 3, True, False
                    
                Case "3+", "3**", "3S", "3+S", "3*S", "3**S", "3F", "3+F", "3*F", "3**F"
                    set_color cell, 2, 3, True, False
                    
                Case "RO", "RC", "RFI":
                    set_color cell, 3, 36, True, False
                
                Case "F", "DISP":
                    set_color cell, 3, 34, True, False
                    
                Case "M":
                    set_color cell, 2, 30, True, False
                
                Case "DS":
                    set_color cell, 2, 32, True, False
                
                End Select
                
                Set next_cell = cell.Offset(, 1)
                Set next_next_cell = cell.Offset(, 2)
                
                'se siamo nella penultima colonna del primo quadrante:
                'la cella successiva è stata impostata, ma la cella dopo è la prima del secondo quadrante
                If col = 6 Then
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'se siamo nell'ultima colonna del primo quadrante
                'la cella successiva è la prima del secondo quadrante, quella dopo ancora è la seconda
                If col = 7 Then
                    Set next_cell = cell.Offset(, 3)
                    Set next_next_cell = cell.Offset(, 4)
                End If
                
                'controlla condizioni di ERRORE (in ROSSO)
                '-----------------------------------------
                'ignora condizioni di errore legate al 3 se si esamina l'ultima colonna del secondo quadrante
                If col < 16 Then
                    'altrimenti considera alcune condizioni di ERRORE
                    Select Case Left(cell, 1)
                    Case "3"
                        'un 3 non può essere seguito da un 2 o da un 1
                        If next_cell Like "2*" Or next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                    
                        'un 3 deve essere seguito da due celle R* oppure da un altro 3
                        If Left(next_cell, 1) Like "[Rr]" And Not (Left(next_next_cell, 1) Like "[Rr]") Then
                            set_color next_next_cell, xlAutomatic, 3, True, True
                        End If
                        
                    Case "2"
                        'un 2 non può essere seguito da un 1
                        If next_cell Like "1*" Then set_color next_cell, xlAutomatic, 3, True, True
                        
                    End Select
                End If
                
            End If
        Next
    Next

End Sub


Private Sub set_color(this_cell As Range, foreground As Integer, background As Integer, bold, italic)
    With this_cell
        With .Font
            .bold = True
            .italic = True
            .ColorIndex = foreground
        End With
        If this_cell.Cells.Count = 1 Then
            If .Interior.ColorIndex <> 46 Then
                .Interior.ColorIndex = background
            End If
        Else
            .Interior.ColorIndex = background
        End If
    End With
    
End Sub



Private Function count_of(ByVal r As Range, what As String)
Dim vect() As Variant, v As Variant, i As Integer, s As String
    
    ReDim vect(1 To r.Cells.Count)
    For Each v In r.Cells
        i = i + 1
        vect(i) = v
    Next
    s = Join(vect, vbNullChar) & vbNullChar
    count_of = Len(Replace(s, what, what & "*")) - Len(s)
    
End Function

di Lisa B. data: 19/03/2015 15:05:19
Ciao V.Frac... Ad un primo veloce test ho visto che gli errori riscontrati prima ora non sono più presenti...

Eseguiro' un test più approfondito più tardi e ti farò sapere.

Come sempre... Ti dco... GRAZIE DI CUORE ❤
di Vecchio Frac data: 19/03/2015 15:36:55
Bene, ne sono confrontato :)
Nel frattempo ti allego un piccolo file Word con le spiegazioni di tutto il codice... ti servirà per la manutenzione futura quindi scaricalo perchè fra otto giorni verrà rimosso dal sistema ;)
Allego: "COLORIZE per Lisa.rtf"
(ho preferito il formato rtf perchè è più universale del docx)
di Lisa B. data: 19/03/2015 20:06:01
V.Frac... Ho letto il file chw mi hai allegato... Sono senza parole per ciò che hai fatto...

Ti sono GRATA per ciò che hai fatto...

Grazie davvero
di Lisa B. data: 20/03/2015 08:59:34
Rimane in sospeso solo una cosa...

La cena

Grazie di CUORE
di Vecchio Frac data: 20/03/2015 09:23:44
Oh LOL...
Grazie, considerala come una cosa fatta, perchè non credo che vorresti vedermi arrivare con moglie e figli al seguito ^_^

Vuoi Approfondire?