Innanzitutto sul foglio Archivio va inserito il seguente codice
- Codice: Seleziona tutto
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("B6:BA6")) Is Nothing Then Exit Sub
NomeR = ActiveCell.Value
If NomeR = "T" Then
NomeR = "TUTTE LE RUOTE"
End If
RRuota = Target.Column
RRP = RRuota + 4
If RRuota = 2 Then RRP = 57
Cancel = True
Call CercaAmbo
End Sub
Poi nel modulo vanno inserite queste 4 macro
- Codice: Seleziona tutto
Sub CercaAmbo()
RAMBO = 0
MRAMBO = 0
Freq = 0
If Worksheets("Archivio").Range("E3").Value = "A" Then
Worksheets("Archivio").Range("E3").Value = "M"
Call CercaAutomArch
Exit Sub
End If
Ambo = Worksheets("Archivio").Range("B3").Value
Worksheets("Archivio").Select
Ue = Worksheets("Archivio").Range("C" & Rows.Count).End(xlUp).Row
Range(Cells(8, 3), Cells(Ue, 57)).Select
Selection.Interior.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
For R = 8 To Ue
If RRuota = 2 Then RRuota = 3
For Col1 = RRuota To RRP
XCF = Int((Col1 - 2) / 5) * 5 + 7
'XCF = XC + 4
AA = Cells(R, Col1).Value * 100
For Col = RRuota To RRP
If Cells(R, Col1).Value = Cells(R, Col).Value Then GoTo salta
If Col > XCF Then GoTo salta
AmboE = AA + Cells(R, Col).Value
If AmboE = Ambo Then
Cells(R, Col).Select
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
Cells(R, Col1).Select
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
If MR = 0 Then
MTRAMBO = R - 8
RATT = R - 8
End If
MR = 1
MRAMBO = R - RAMBO - 8
If RAMBO = 0 Then RAMBO = MRAMBO
If RAMBO < MRAMBO Then RAMBO = MRAMBO - 1
Freq = Freq + 1
MTRAMBO = R - 8
End If
salta:
Next
Next
Next
If RATT = "" Then RATT = Ue - 7
Worksheets("Archivio").Range("J3").Value = RATT
If MRAMBO = "" Then MRAMBO = -1
If Ue - MTRAMBO - 8 > RAMBO Then RAMBO = Ue - MTRAMBO - 8
Worksheets("Archivio").Range("I3").Value = RAMBO
Worksheets("Archivio").Range("K3").Value = Freq
Worksheets("Archivio").Range("I1").Value = NomeR
Worksheets("Archivio").Range("E3").Select
End Sub
Sub CercaAutomArch()
MFreq = 0
Application.ScreenUpdating = True
Application.ScreenUpdating = Default
Application.ScreenUpdating = False
Application.Calculation = xlManual
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Worksheets("Archivio").Select
Ue = Worksheets("Archivio").Range("C" & Rows.Count).End(xlUp).Row
For I = 1 To 89
Application.StatusBar = "Elaborazione Max Freq Ambo su " & NomeR & " ... " & Int(I / 90 * 100) & " %"
With Worksheets("Archivio").Range(Cells(8, RRuota), Cells(Ue, RRP))
Set C = .Find(I, LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If C.Value = I Then
Riga = C.Row
Call CercaB
End If
Set C = .FindNext(C)
'On Error Resume Next
Loop While Not C Is Nothing And C.Address = firstAddress
'On Error GoTo 0
End If
End With
Next
Call CercaAmbo
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = oldStatusBar
Application.DisplayStatusBar = False
End Sub
Sub CercaB()
For B = I + 1 To 90
Freq = 0
With Worksheets("Archivio").Range(Cells(Riga, RRuota), Cells(Riga, RRP))
Set D = .Find(B, LookIn:=xlValues)
If Not D Is Nothing Then
firstDAddress = D.Address
Do
If D.Value = B Then
AmboAut = I * 100 + B
Call CercaAmboA
'Freq = Freq + 1
End If
Set D = .FindNext(D)
On Error Resume Next
Loop While Not D Is Nothing And D.Address <> firstDAddress
On Error GoTo 0
End If
End With
Next
End Sub
Sub CercaAmboA()
For R = 8 To Ue
For Col1 = RRuota To RRP
AA = Cells(R, Col1).Value * 100
For Col = RRuota To RRP
If Cells(R, Col1).Value = Cells(R, Col).Value Then GoTo salta
'Freq = 0
AmboE = AA + Cells(R, Col).Value
If AmboE = AmboAut Then Freq = Freq + 1
If Freq > MFreq Then
MFreq = Freq
MAmboAut = AmboAut
End If
salta:
Next
Next
Next
Worksheets("Archivio").Range("B3").Value = MAmboAut
End Sub
Ora potrai cancellare il foglio Ritardi_Ambo anzi visto che il file si è talmente ridotto lo allego per maggior chiarezza e per dare a tutti la possibilità di utilizzarlo.
Ciao
P.s.
1) I tempi in Automatico sono notevolmente migliorati solo 13 secondi (ruota) contro i 90 della versione precedente
2) Devo ancora intervenire sul pulsante "T" (Tutte le Ruote) in quanto non mi risulta facile scansionare un'area di 55 colonne suddivise in 11 sezioni (da 5 colonne cad) per determinare l'ambo-ruota ma sicuramente qualche volontario potrà darci una mano