Ciao Vladimiro,
in Access ho la possibilità di costruirmi una maschera con all'interno una barra di scorrimento che mi mostra il tempo che impiega una routine ad elaborare dei dati abbastanza lunghetti:
Mettiamo come esempio una macro che Norman ha risolto con successo ripetuta per 18 volte:
'=========>>
Option Explicit
'--------->>
Public Sub SR_1()
Dim Rng As Range, Rng2 As Range, rCell As Range
Dim RngSomma As Range, RngGiallo As Range
Dim dSum As Double
Dim bMatch As Boolean
Const sIntervallo As String = "C2:T3" '<<=== Modifica
Const sIntervallo2 As String = "A4:A9" '<<=== Modifica
Const sIntervallo3 As String = "C10:T10" '<<=== Modifica
Const sSomma As String = "U6" '<<=== Modifica
Set Rng = Range(sIntervallo)
Set Rng2 = Range(sIntervallo2)
Set RngSomma = Range(sSomma)
Set RngGiallo = Range(sIntervallo3)
RngGiallo.Interior.Color = xlNone
For Each rCell In Rng.Cells
With rCell
bMatch = Not IsError(Application.Match(.Value, Rng2, 0))
If bMatch Then
Intersect(.EntireColumn, RngGiallo).Interior.Color = vbYellow
End If
End With
Next rCell
For Each rCell In Rng.Rows(1).Offset(8).Cells
With rCell
If .Interior.Color <> vbYellow Then
dSum = dSum + .Value
End If
End With
Next rCell
RngSomma.Value = dSum
End Sub
'<<=========
===
Regards,
Norman
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, rCell As Range
Set Rng = Intersect(Me.Range("A1:A18"), Target)
If Rng Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each rCell In Rng.Cells
With rCell
If Not IsEmpty(.Value) Then
Select Case .Address(0, 0)
Case "A1": Call SR_1
Case "A2": Call SR_2
Case "A3": Call SR_3
Case "A4": Call SR_4
Case "A5": Call SR_5
Case "A6": Call SR_6
Case "A7": Call SR_7
Case "A8": Call SR_8
Case "A9": Call SR_9
Case "A10": Call SR_10
Case "11": Call SR_11
Case "A12": Call SR_12
Case "A13": Call SR_13
Case "A14": Call SR_14
Case "A15": Call SR_15
Case "A16": Call SR_16
Case "A17": Call SR_17
Case "A18": Call SR_18
End Select
End If
End With
Next rCell
Application.ScreenUpdating = True
End Sub
'<<=========
Potresti scaricare il mio file di prova Vladimiro20200330.xlsm
'<<=========
Siccome nel mio file originale l'elaborazione dei dati non è istantanea, mi farebbe comodo un qualcosa simile alla figura postata che compaia all'inizio della prima routine per scomparire alla fine dell'ultima routine.
E' possibile?
Senza alcuna conoscenza delle tue diciotto macro, e nel esempio citato da te, non vi è alcun modo che il codice possa prevedere il tempo di esecuzione totale e, quindi, la percentuale di tempo di esecuzione trascorso.
Detto ciò, se il tempo di esecuzione di ciascuna delle diciotto macro fosse uguale, si potrebbe creare una barra di scorrimento.
Tuttavia, in base al principio che prevenire è meglio che curare, sarebbe meglio modificare le singole macro al fine di evitare ritardi non necessari.
===
Regards,
Norman
Ciao Norman,
le macro, anche se potrebbero sicuramente essere migliorate, penso che vadano bene.
Il tempo impiegato è di circa 8 secondi.
Comunque per ogni Sub richiamata le macro in gioco sono le seguenti:
Public Sub SR_1()
Dim PulR1 As Shape, cPulR1 As Shape, i As Integer
' Const sPassword As String = "MiaPassword"
Const rPul1 As String = "SR_1"
Const crPul1 As String = "CR_1"
For i = 0 To 1
Select Case Range("O1")
Case Is = i
Beep
Exit Sub
End Select
Next i
'ActiveSheet.Unprotect Password:=sPassword
With ActiveSheet
Set PulR1 = .Shapes(rPul1)
Set cPulR1 = .Shapes(crPul1)
End With
With PulR1
If Range("R2001") = 1 Then
.Fill.ForeColor.RGB = RGB(244, 176, 132)
Range("D15") = ""
Range("R2001") = 0
Call Escludi_Puntate_Gioco
Else
Range("D15") = 1
Range("R2001") = 1
.Fill.ForeColor.RGB = RGB(0, 112, 192)
Call Escludi_Puntate_Gioco
End If
End With
With cPulR1
.Fill.ForeColor.RGB = RGB(244, 176, 132)
Range("R1951") = 1
End With
End Sub
Public Sub Escludi_Puntate_Gioco()
Dim Rng As Range, Rng2 As Range, rCell As Range, rCell1 As Range
Dim RngConteggio As Range, RngSomma As Range, RngSomma1 As Range, RngGiallo As Range, RngGiallo1 As Range
Dim iCtr As Long
Dim dSum As Double
Dim dSum1 As Double
Dim bMatch As Boolean
Const sIntervallo As String = "U1:ABU10"
Const sIntervallo2 As String = "O57:O1307"
Const sConteggio As String = "R17"
Const sSomma As String = "R20"
Const sSomma1 As String = "S23"
Set Rng = Range(sIntervallo)
Set Rng2 = Range(sIntervallo2)
Set RngConteggio = Range(sConteggio)
Set RngSomma = Range(sSomma)
Set RngSomma1 = Range(sSomma1)
Set RngGiallo = Rng.Rows(1).Offset(17)
Set RngGiallo1 = Rng.Rows(1).Offset(22)
Rng.Offset(17).Rows(1).Interior.Color = vbYellow
For Each rCell In Rng.Cells
With rCell
bMatch = Not IsError(Application.Match(.Value, Rng2, 0))
If bMatch Then
Intersect(.EntireColumn, RngGiallo).Interior.Color = RGB(0, 112, 192)
End If
End With
Next rCell
For Each rCell In Rng.Rows(1).Offset(17).Cells
With rCell
If .Interior.Color <> vbYellow Then
iCtr = iCtr + 1
dSum = dSum + .Value
End If
End With
Next rCell
RngConteggio.Value = iCtr
RngSomma.Value = dSum
Rng.Offset(22).Rows(1).Interior.Color = vbYellow
For Each rCell1 In Rng.Cells
With rCell1
bMatch = Not IsError(Application.Match(.Value, Rng2, 0))
If bMatch Then
Intersect(.EntireColumn, RngGiallo1).Interior.Color = RGB(0, 112, 192)
End If
End With
Next rCell1
For Each rCell1 In Rng.Rows(1).Offset(22).Cells
With rCell1
If .Interior.Color <> vbYellow Then
dSum1 = dSum1 + .Value
End If
End With
Next rCell1
RngSomma1.Value = dSum1
End Sub
Vladimiro
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
