in un file ho 12 fogli con i nomi dei mesi.
ho una macro (e' grezza ma funziona),
che quando la avvio opera sul foglio attivo.
vorrei poter aggiungere un ciclo , in modo che quando sono in un mese qualunque ed avvio tale macro
questa operi anche sugli altri 11 mesi.
- Codice: Seleziona tutto
Sub coloro1()
Dim campo As Range, c As Range
Set campo = Range("h6:al105")
If [b6] = "" Then
MsgBox "B6 ed il mese e' vuoto...", vbCritical
'--------------------------
'RIATTIVO LE APPLICATION
With Application
.Calculation = xlCal
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
'---coloro 18,30----------------
RRs = 2
CCs = 24 ' colonna =X
NumS = Cells(RRs, CCs).Value
For RRT = 6 To 105
For cct = 8 To 38 ' 37=col Ay
If Cells(RRT, cct).Value = NumS Then
With Cells(RRT, cct)
.Interior.ColorIndex = 8 'colore cella
.Font.ColorIndex = 1 ' colore carattere
End With
End If
Next cct
Next RRT
'---coloro BASE----------------
RRs = 2
CCs = 23 ' colonna W
NumS = Cells(RRs, CCs).Value
For RRT = 6 To 105
For cct = 8 To 38
If Cells(RRT, cct).Value = NumS Then
With Cells(RRT, cct)
.Interior.ColorIndex = 36 'colore cella
.Font.ColorIndex = 1 ' colore carattere
End With
End If
Next cct
Next RRT
'---coloro 20----------------
RRs = 2
CCs = 25 ' colonna =Y
NumS = Cells(RRs, CCs).Value
For RRT = 6 To 105
For cct = 8 To 38
If Cells(RRT, cct).Value = NumS Then
With Cells(RRT, cct)
.Interior.ColorIndex = 1 'colore cella
.Font.ColorIndex = 19 ' colore carattere
End With
End If
Next cct
Next RRT
'---coloro r1 rep merc----------------
RRs = 2
CCs = 26 ' colonna =Z
NumS = Cells(RRs, CCs).Value
For RRT = 6 To 105
For cct = 8 To 38
If Cells(RRT, cct).Value = NumS Then
With Cells(RRT, cct)
.Interior.ColorIndex = 4 'colore cella
.Font.ColorIndex = 1 ' colore carattere
End With
End If
Next cct
Next RRT
'---coloro r2 rep domen----------------
RRs = 2
CCs = 27 ' colonna =AA
NumS = Cells(RRs, CCs).Value
For RRT = 6 To 105
For cct = 8 To 38
If Cells(RRT, cct).Value = NumS Then
With Cells(RRT, cct)
.Interior.ColorIndex = 7 'colore cella
.Font.ColorIndex = 1 ' colore carattere
End With
End If
Next cct
Next RRT
'---------------------------------
For Each c In campo
With Cells(c.Row, c.Column)
Select Case True
'---coloro LL da lun-ven--------
Case c.Text = "LL" And (Cells(5, c.Column) <> 7 And Cells(5, c.Column) <> 1)
.Font.ColorIndex = 2
.Interior.ColorIndex = 9
'---coloro RI da lun-ven--------
Case c.Text = "RI" And (Cells(5, c.Column) <> 7 And Cells(5, c.Column) <> 1)
.Font.ColorIndex = 2
.Interior.ColorIndex = 9
'---coloro B sabato--------
Case c.Text = "B" And (Cells(5, c.Column) = 7) ' 7= sab
.Font.ColorIndex = 2
.Interior.ColorIndex = 11
'---coloro B domenica--------
Case c.Text = "B" And (Cells(5, c.Column) = 1) '1 = domen
.Font.ColorIndex = 2 ' bianco carat
.Interior.ColorIndex = 51 ' sfondo
'---coloro BF da lun-ven Base festivo--------
Case c.Text = "BF" And Cells(5, c.Column) <> 7 And Cells(5, c.Column) <> 1
.Font.ColorIndex = 2 ' bianco carat
.Interior.ColorIndex = 3 'rosso sfondo
End Select
End With
Next c
'----adatto largh col-----------------------
Columns("C:Al").ColumnWidth = 4
Columns("g").ColumnWidth = 1
Range("AK1").Select
'-------------
Call evidenziaB ' metto cornice b3-b2
Range("a2").Select
ActiveWindow.DisplayGridlines = False 'protegge il fgl
End Sub
allego il file
https://dl.dropboxusercontent.com/u/96374724/stampa%20mesi.rar
ciao