PDA

View Full Version : [VBA][EXCEL]differenza di date su colonna, modifica colore righe, msgbox di riepilogo


radeon_snorky
07-09-2009, 10:56
piccolo questito velocissimo:
Sub scadenze()
Dim settimana As Long
Dim mese As Long
Dim trimestre As Long
Dim differenza As Long
Dim scadenza As Date
Dim adesso As Date
settimana = 7
mese = 30
trimestre = 90
adesso = Now()
scadenza = Cells.Range("O127")
differenza = DateDiff("d", adesso, scadenza)
If differenza < trimestre and differenza > mese Then
' riga colore AZZURRO
End If
If differenza < mese And differenza > settimana Then
' riga colore ARANCIONE
End If
If differenza < settimana Then
' riga colore ROSSO
End If
msgbox "pratiche urgenti: 1 2 3 ; pratiche in scadenza: 4 5 6 ; prossime pratiche: 7 8 9 "
End Sub

avrei bisogno che questo codice venisse eseguito su un range e si ripetesse per tutte le celle della colonna "O" che risultano piene e al posto del commento vorrei il codice per impostare il colore alla row corrispondente
e solo alla fine mostrare una msgbox con il riepilogo di tutte le righe modificate (quindi un msgbox che all'occorrenza possa contenere anche decine di righe) mi serve capire come memorizzare il riferimento riga, poi vedo di cavarmela con la realizzazione del messaggio...

grazie!

radeon_snorky
07-09-2009, 15:48
Dim settimana As Long
Dim mese As Long
Dim trimestre As Long
Dim differenza As Long
Dim scadenza As Date
Dim adesso As Date
Dim index As Long
Dim lastrif As Long
settimana = 7
mese = 30
trimestre = 90
adesso = Now()
lastrif = Sheets("pratiche").Range("O" & Rows.Count).End(xlUp).Row
For i = 3 To lastrif
index = i
If Sheets("pratiche").Range("O" & index).Value = "" Then
Rows(index).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = 2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
GoTo 10
End If
scadenza = Sheets("pratiche").Range("O" & index).Value
scadenza = CDate(Replace(scadenza, " ", "/"))
differenza = DateDiff("d", adesso, scadenza)
If differenza > mese Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 2
End With
GoTo 10
End If
If differenza < mese And differenza > settimana Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 45
End With
End If
If differenza < settimana Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 3
End With
End If
10:
Next i
mi ci sono messo d'impegno ed ecco il risultato! (scarsino, eh!)
consigli su come migliorarlo?

EDIT:
sistemato un errorino...
e aggiungo una domanda: se metto il codice all'avvio fa proprio quello che mi aspetto... se però lo metto in un pulsante, no! mi spiego: se cancello una data e avvio la macro... non mi vede il cambiamento e la riga rimane colorata! se chiudo il file e lo riapro ecco che la stessa macro posizionata in apertura file mi aggiorna correttamente i colori, perché?

radeon_snorky
11-09-2009, 10:54
se fosse utile a qualcuno:
Sub scadenze()
Dim settimana As Long
Dim mese As Long
Dim differenza As Long
Dim scadenza As Date
Dim adesso As Date
Dim index As Long
Dim lastrif As Long
settimana = 7
mese = 30
adesso = Now()
lastrif = Sheets("pratiche").Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To lastrif
index = i
If Sheets("pratiche").Range("O" & index).Value = "" Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 34
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
GoTo 10
End If
scadenza = Sheets("pratiche").Range("O" & index).Value
scadenza = CDate(Replace(scadenza, " ", "/"))
differenza = DateDiff("d", adesso, scadenza)
If differenza > mese Then
Rows(index).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End If
If differenza < mese And differenza > settimana Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 45
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With

End If
If differenza <= settimana Then
Rows(index).Select
With Selection.Interior
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
MsgBox ("la pratica " & Sheets("pratiche").Range("A" & index).Value & " risulta in scadenza")
End If
10:
Next i
Sheets("pratiche").Range("J1").Value = Now()
Worksheets("pratiche").Range("A1").Select
End Sub
un commento veloce per spiegare cosa fa il codice:
inizialmente assegno dei valori alle variabili settimana mese e adesso (solo per mia personale comodità... si possono evitare usando i valori numerici!)
poi cerco l'ultima riga compilata nel foglio (cerco l'ultima pratica inserita)
così posso ciclare un numero di volte pari alle righe scritte (3 to lastrif, dove 3 è la posizione della prima pratica e lastrif l'ultima)
poi inizio a verificare se la cella della colonna O di quella riga (O & index, che varia ad ogni ciclo) è vuota ( "" ) se così è, dopo aver colorato la riga, salto a piè pari (goto 10) alla fine del ciclo (10: ) e aumento di uno (next i)
nel caso la cella O & index fosse piena calcolo la differenza tra il contenuto (scadenza) e now() (che ho chiamato "adesso") e la esprimo in giorni "d" poi verifico che la differenza sia maggiore, compresa o inferiore a certi valori e a seconda del caso modifico la riga con colori diversi e, in ultimo, avviso con un msgbox quelle che sono in "scadenza".
le ultime due righe mi servono per altre questioni e possono essere tolte, comunque lo scpiego:
su j1 vado a scrivere now() per poter verificare (da un'altra macro) se il controllo è già avvenuto oppure è necessario fare un "refresh" delle scadenze, magari perché si vuole mettere la verifica all'apertura del file ma non si vuole che succeda sempre ma solo alla prima apertura giornaliera o magari alla prima apertura dopo x ore; il select su A1 mi serve solamente per spostarmi su A1 visto che il ciclo si ferma evidenziando l'ultima riga, è solo un vezzo...

NB se avete consigli su come migliorare il codice fate pure!!! io son sempre qua!!!

ps sto ancora cercando un modo per creare un msgbox che contenga tutti gli avvisi (quindi in numero variabile) raggruppati in un solo messaggio!!!! HELP