Moderatori: Anthony47, Flash30005
Sub ColoraATQC()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Range("BG305:DI305").ClearContents
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
riga = UR + 13
Col = 94 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 59 To 113 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
se non trovi Definisci Nome
Sub ColoraATQC()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Range("BG305:LE305").ClearContents
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
riga = UR + 13
Col = 94 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 59 To 113 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("DW3:FY" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<2° BLOCCO
riga = UR + 13
Col = 94 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 127 To 181 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("GM3:IO" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<3° BLOCCO
riga = UR + 13
Col = 94 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 195 To 249 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("JC3:LE" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<4° BLOCCO
riga = UR + 13
Col = 94 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 263 To 317 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub ColoraATQC()
Application.ScreenUpdating = False '<<<<< lascia così
Application.Calculation = xlManual '<<<<< lascia così
UR = 302 '<<<<< lascia così
Col = 26 '<<<<<<<<<<< INSERISCI QUESTO VALORE QUI
Range("BG305:DI305").ClearContents '<<<<<<<< lascia così
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
riga = UR + 13 '<<<<<<<<<<<< lascia così
Col = Col + 68 '<<<< Cambiare solo questo valore e riportarlo su tutti i blocchi (calcola automaticamente la nuova colonna)
Range("BG305:DI305").ClearContents '<<<<<<<< lascia così
Sub ColoraATQC()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Col = 26 '<<<<<<<<<<< INSERISCI QUESTO VALORE QUI
Range("BG305:LE305").ClearContents
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
riga = UR + 13
Col = 68 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 59 To 113 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("DW3:FY" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<2° BLOCCO
riga = UR + 13
Col = 68 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 127 To 181 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("GM3:IO" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<3° BLOCCO
riga = UR + 13
Col = 68 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 195 To 249 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Range("JC3:LE" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<4° BLOCCO
riga = UR + 13
Col = 68 '<<<<<<<<<<<<< cambiare in funzione del BLOCCO
For CC = 263 To 317 Step 5
riga = riga + 1
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = UR To 3 Step -1
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then ContaA = ContaA + 1
Next CCR
Select Case ContaA
Case 2
Ambi = Ambi + 1
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
Next RR
Cells(riga, Col).Value = Ambi
Cells(riga, Col + 1).Value = Terni
Cells(riga, Col + 2).Value = Quaterne
Cells(riga, Col + 3).Value = Cinquine
Next CC
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Col = Col + 68 '<<<< Cambiare solo questo valore e riportarlo su tutti i blocchi (calcola automaticamente la nuova colonna)
Torna a Applicazioni Office Windows
Macro copia dati colonne non contigue su un altro file excel Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 5 |
Inserire valore assoluto in formula Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 30 ospiti