Per quanto riguarda quella postilla di cui ieri ti accennavo, nulla da aggiungere; va bene così.
Ci sono però due inghippi non gravi ma che non sono riuscito a risolvere:
Il primo riguarda gli storici del secondo blocco (6 Numeri per ambo, prima sezione o gruppo) Foglio storici range AU:BP; non marca i ritardi storici sulla ruota di Roma.
Il secondo riguarda il foglio 1 colonna A laddove colora di verde i blocchi processati. Questi, che in un primo momento funzionavano (colorandosi) non funzionano più dal momento in cui ho processato tutti i blocchi insieme. Ma quest'ultimo sarebbe il meno.
Ciao
Allego foto e macro corrette con i nuovi range.
- Codice: Seleziona tutto
Sub ColATQC_E_Storico()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR = 302
Col = 18
passo = 68
PassoSt = 46
ColI = 59
ColF = ColI + 54
Worksheets("Foglio1").Select
UC = Range("BV316").End(xlToRight).Column
If UC > 80 Then
MsgBox "Occorrono almeno 5 numeri"
Exit Sub
End If
Range("BG305:QK305").ClearContents ' cambiare se necessario
For ciclo = Range("C307").Value - 4 To Range("E307").Value - 4
Range(Cells(3, ColI + (ciclo - 1) * passo), Cells(UR, ColF + (ciclo - 1) * passo)).Interior.ColorIndex = xlNone
SR = 0
FoB = 2
riga = UR + 13
Col = Col + passo
For CC = 59 + (ciclo - 1) * passo To 113 + (ciclo - 1) * passo Step 5
FoB = FoB + 2
SR = SR + 1
CCS = 1 + PassoSt * (ciclo - 1) + (SR - 1) * 2
CCS2 = CCS + PassoSt / 2
riga = riga + 1
Estratto = 0
Ambi = 0
Terni = 0
Quaterne = 0
Cinquine = 0
For RR = 3 To UR
EV = 0
ContaA = 0
For CCR = CC + 0 To CC + 4
If Val(Cells(RR, CCR)) > 0 Then
ContaA = ContaA + 1
If ContaA > 1 Then EV = 2
If ContaA = 1 Then EV = 1
End If
Next CCR
CI = xlNone
Select Case ContaA
Case 1
Estratto = Estratto + 1
Cells(305, CC + 2).Value = UR - RR
' Cells(318 + (ciclo - 1) * 2, FoB).Value = UR - RR
Case 2
Ambi = Ambi + 1
CI = 15
Cells(305, CC + 2).Value = UR - RR
Cells(312 + (ciclo - 1) * 2, FoB).Value = UR - RR
Case 3
Terni = Terni + 1
CI = 4
Cells(305, CC + 2).Value = UR - RR
Cells(312 + (ciclo - 1) * 2, FoB).Value = UR - RR
Case 4
Quaterne = Quaterne + 1
CI = 33
Cells(305, CC + 2).Value = UR - RR
Cells(312 + (ciclo - 1) * 2, FoB).Value = UR - RR
Case 5
Cinquine = Cinquine + 1
CI = 45
Cells(305, CC + 2).Value = UR - RR
Cells(312 + (ciclo - 1) * 2, FoB).Value = UR - RR
Case Else
CI = xlNone
End Select
Range(Cells(RR, CC), Cells(RR, CC + 4)).Interior.ColorIndex = CI
If EV > 0 Then
Cells(324 + (ciclo - 1) * 2, FoB).Value = UR - RR '<<< incollare qui (non commentata)
Conc = Val(Cells(RR, 1))
URS2 = Worksheets("Storici").Cells(Rows.Count, CCS2).End(xlUp).Row
ConcSt2 = Val(Worksheets("Storici").Cells(URS2, CCS2))
If Conc > ConcSt2 Then
Worksheets("Storici").Cells(URS2 + 1, CCS2).Value = Conc
Worksheets("Storici").Cells(URS2 + 1, CCS2 + 1).Value = Conc - ConcSt2
End If
If EV = 2 Then
URS = Worksheets("Storici").Cells(Rows.Count, CCS).End(xlUp).Row
ConcSt = Val(Worksheets("Storici").Cells(URS, CCS))
If Conc > ConcSt Then
Worksheets("Storici").Cells(URS + 1, CCS).Value = Conc
Worksheets("Storici").Cells(URS + 1, CCS + 1).Value = Conc - ConcSt
End If
End If
End If
Next RR
Cells(riga, Col).Value = Estratto
Cells(riga, Col + 1).Value = Ambi
Cells(riga, Col + 2).Value = Terni
Cells(riga, Col + 3).Value = Quaterne
Cells(riga, Col + 4).Value = Cinquine
Next CC
Range("A" & 312 + (ciclo - 1) * 2).Interior.ColorIndex = 4
Range("A" & 324 + (ciclo - 1) * 2).Interior.ColorIndex = 4
Next ciclo
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub ppp()
UC = Range("BV316").End(xlToRight).Column
MsgBox UC
End Sub
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
Blocco1 = "BW316:CF326"
Blocco2 = "EM316:EV326"
Blocco3 = "HC316:HL326"
Blocco4 = "JS316:KB326" '<<<<<< inserire il range corretto su excel 2007 per le ottine
Blocco5 = "MI316:MR326" '<<<<<< inserire il range corretto su excel 2007 per le novine
Blocco6 = "OY316:PH326" '<<<<<< inserire il range corretto su excel 2007 per le decine
Inizio = "C307"
Fine = "E307"
If Not Application.Intersect(Target, Range(Blocco1)) Is Nothing Then
Range("A312").Interior.ColorIndex = xlNone
Range("A324").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Blocco2)) Is Nothing Then
Range("A314").Interior.ColorIndex = xlNone
Range("A326").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Blocco3)) Is Nothing Then
Range("A316").Interior.ColorIndex = xlNone
Range("A328").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Blocco4)) Is Nothing Then
Range("A318").Interior.ColorIndex = xlNone
Range("A330").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Blocco5)) Is Nothing Then
Range("A320").Interior.ColorIndex = xlNone
Range("A332").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Blocco6)) Is Nothing Then
Range("A322").Interior.ColorIndex = xlNone
Range("A334").Interior.ColorIndex = xlNone
End If
If Not Application.Intersect(Target, Range(Inizio)) Is Nothing Then
If Target > Range("AT310").Value Then
MsgBox "Il Blocco Inizio non può essere maggiore del Blocco Fine"
Range("AT310").Value = Target
End If
End If
If Not Application.Intersect(Target, Range(Fine)) Is Nothing Then
If Target < Range("AR310").Value Then
MsgBox "Il Blocco Fine non può essere Minore del Blocco Inizio"
Range("AR310").Value = Target
End If
End If
End Sub