Moderatori: Anthony47, Flash30005
UR = 302 '<<<< esistente lasciare
Range("A305:IO305").ClearContents '<<<< aggiungere e adattare all'ultima tuo colonna NON ripetere negli altri blocchi
'----- inizio blocco da copiare
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
For CC = 59 To 109 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("A305:IO305").ClearContents
Sub ColoraATQC()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Range("BG305:QM305").ClearContents '<<<< aggiungere e adattare all'ultima tuo colonna NON
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
For CC = 59 To 109 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("DW3:FY" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<2° BLOCCO
For CC = 127 To 181 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("GM3:IO" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<3° BLOCCO
For CC = 195 To 249 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("JC3:LE" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<4° BLOCCO
For CC = 263 To 317 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("LS3:NU" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<5° BLOCCO
For CC = 331 To 385 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("OK3:QM" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<6° BLOCCO
For CC = 401 To 455 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
'AUTORE: AVATAR3 AL QUALE VA UN GROSSO GRAZIE!!!!!
'20.06.2011
Avatar3 ha scritto:C'era scritto che dovevi adattarla...
Lucio Peruggini ha scritto:
Buona serata
Gentilmente, alla macro già in uso è possibile aggiungere una opzione che inserisca nelle colonne ( CD316:CM326 ) la quantità di Ambi – Terni – Quaterne e Cinquine estrapolati dalle colonne (DK3:DU302)?
Avatar, come ricorderai hai fatto questa macro (che allego) perché le formule non permettevano di fissare sempre il medesimo ritardo della riga 305. Il problema è uguale anche per le celle indicate sopra. Nella griglia sottostante a destra e colorata in grigio, quando aggiungo in archivio nuove estrazioni, non mantiene la formula e quindi, a ogni nuova estrazione che ricordo: (aggiungo una e ne tolgo una sopra) in pratica sono sempre 300.
Ricorderai anche, trattasi di sei moduli che ovviamente posso anche aumentare grazie ai tuoi insegnamenti. Quindi nella 1 foto vedi le terzine ed è il primo modulo; nella foto 2 vedi il modulo sei che sono ottine. Se non sono stato chiaro, riproverò a spiegarmi meglio.
Se necessita allegherò anche l’excel completo.
Saluti
Sub ColoraATQC()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Range("BG305:QK305").ClearContents
Range("BG3:DI" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<1° BLOCCO
For CC = 59 To 113 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("DW3:FY" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<2° BLOCCO
For CC = 127 To 181 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("GM3:IO" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<3° BLOCCO
For CC = 195 To 249 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("JC3:LE" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<4° BLOCCO
For CC = 263 To 317 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("LS3:NU" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<5° BLOCCO
For CC = 331 To 385 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Range("OI3:QK" & UR).Interior.ColorIndex = xlNone '<<<<<<<<<<<<<<<<<<<<<6° BLOCCO
For CC = 399 To 453 Step 5
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
CI = 15
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 3
CI = 4
Cells(305, CC + 2).Select
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 4
CI = 33
If Cells(305, CC + 2) = "" Then Cells(305, CC + 2).Value = UR - RR
Case 5
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
Next CC
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
'AUTORE: AVATAR3 AL QUALE VA UN DOVEROSO GRAZIE!!!!!
'20.06.2011
=CONTA.SE(BA;2)
=CONTA.SE(BA;3)
Avatar3 ha scritto:<prima di passare alla macro che effettua i conteggi degli ambi terni, quaterne e cinquine
perché solo questo ho capito
le ottine in CD e CM non so cosa siano
hai provato a inserire un Nome da Menu Inserisci -> Definisci -> Nome
Metti BA e selezioni le celle da DK3:DK302
Poi nella fomula degli ambi metterai
- Codice: Seleziona tutto
=CONTA.SE(BA;2)
terni
- Codice: Seleziona tutto
=CONTA.SE(BA;3)
anche sostituendo le righe il nome del range rimane fisso da 3 a 302
prova con le formule se non riesci spiego meglio
=CONTA.SE(BA;2)
Torna a Applicazioni Office Windows
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 6 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Excel 2016 - Funzione SCARTO + INDIRETTO Autore: pl1957 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 69 ospiti