Ciao Giuseppe,
non ho avuto modo di testarla perché non ho a disposizione i tuoi dati ma se vuoi prova, in una copia del tuo file, la macro così modificata (dove in grassetto metto in rilievo le modifiche specifiche per "gestire" la media finale prestabilita:
Public Sub Tester3ModificataPerMediaFinalePrestabilita()
Dim WB As Workbook
Dim SH As Worksheet
Dim rngPrimaData, rngUltimaData
Dim rngPrimoOrario As Range, rngUltimoOrario As Range
Dim rigaStart As Long, rigaFine As Long
Dim riga2Start As Long, riga2Fine As Long
Dim rngMediaValle As Range, rngScartoMediaValle As Range
Dim Rng As Range, Rng2 As Range, Rng3 As Range
Dim rArea As Range
Dim LRow As Long
Dim iMin As Long, iMax As Long
Dim Criterio1 As Double, Criterio2 As Double
Dim bManutenzione As Boolean
Dim ContaCicli As Long
Const cellaPrimaData As String = "C4" '<<=== Modifica
Const cellaUltimaData As String = "D4" '<<=== Modifica
Const cellaPrimoOrario As String = "C6" '<<=== Modifica
Const cellaUltimoOrario As String = "D6" '<<=== Modifica
Const cellaMediaValle As String = "B3" '<<=== Modifica
Const cellaScartoMediaValle As String = "B5" '<<=== Modifica
Const iPrimaRiga As Long = 14 '<<=== Modifica
'< dichiarazioni variabili e costanti per gestire media finale prestabilita
Dim rngMediaFinalePrestabilita As Range
Dim iMediaPrestabilita As Double
Const cellaMediaFinalePrestabilita As String = "E4" '<<=== da personalizzare
Const iMaxNumeroCicli As Long = 100
'dichiarazioni variabili e costanti per gestire media finale prestabilita />
bManutenzione = True
Set WB = ThisWorkbook
Set SH = WB.ActiveSheet
With SH
Set rngPrimaData = .Range(cellaPrimaData)
Set rngUltimaData = .Range(cellaUltimaData)
Set rngPrimoOrario = .Range(cellaPrimoOrario)
Set rngUltimoOrario = .Range(cellaUltimoOrario)
Set rngMediaValle = .Range(cellaMediaValle)
Set rngScartoMediaValle = .Range(cellaScartoMediaValle)
LRow = LastRow(SH, .Columns("A:A"))
With .Columns(1)
If IsEmpty(rngPrimaData.Value) _
Or IsEmpty(rngUltimaData.Value) Then
bManutenzione = False
Set Rng = .Cells(iPrimaRiga).Offset(0, 3). _
Resize(LRow - iPrimaRiga + 1)
End If
If bManutenzione Then
Criterio1 = CDbl(rngPrimaData.Value + rngPrimoOrario)
Criterio2 = CDbl(rngUltimaData + rngUltimoOrario)
rigaStart = SH.Columns(1).Find( _
What:=CDate(Criterio1), _
After:=.Cells(iPrimaRiga - 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row
rigaFine = SH.Columns(1).Find( _
What:=CDate(Criterio1), _
After:=.Cells(iPrimaRiga - 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
riga2Start = SH.Columns(1).Find( _
What:=CDate(Criterio2), _
After:=.Cells(iPrimaRiga - 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row
riga2Fine = SH.Columns(1).Find( _
What:=CDate(Criterio2), _
After:=.Cells(iPrimaRiga - 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Set Rng2 = .Cells(iPrimaRiga).Resize(rigaStart - iPrimaRiga)
Set Rng3 = .Cells(riga2Fine + 1).Resize(LRow - riga2Fine)
' End With
Set Rng = Union(Rng2, Rng3).Offset(, 3)
End If
iMin = rngMediaValle.Value - rngScartoMediaValle.Value
iMax = rngMediaValle.Value + rngScartoMediaValle.Value
End With
End With
On Error GoTo XIT
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual 'calcolo in manuale prima di inserire le formule RANDBETWEEN
End With
'< settaggi per media finale prestabilita
Set rngMediaFinalePrestabilita = SH.Range(cellaMediaFinalePrestabilita)
iMediaPrestabilita = rngMediaFinalePrestabilita.Value
' settaggi per media finale prestabilita />
With Rng
.NumberFormat = "0.00"
.Formula = "=RANDBETWEEN(" & iMin & "," & iMax & ")*1.01"
'< gestione media finale prestabilita
If iMediaPrestabilita <> 0 And _
iMin < iMediaPrestabilita And _
iMax > iMediaPrestabilita Then
While Application.Average(.Value) <> iMediaPrestabilita And _
ContaCicli < iMaxNumeroCicli
.Calculate
ContaCicli = ContaCicli + 1
Wend
Else
Rng.Calculate
End If
' gestione media finale prestabilita />
For Each rArea In Rng.Areas
With rArea
.Select
.Value = .Value
.Interior.Color = vbYellow '\ Solo per facilitare le prove!
End With
Next rArea
End With
XIT:
With Application
.Calculation = xlCalculationAutomatic 'reimposto il calcolo in automatico
.ScreenUpdating = True
End With
End Sub
In pratica le modifiche impostano il calcolo in manuale prima di inserire le formule CAUSALE.TRA, e se il valore in una cella dedicata all'inserimento della media prestabilita (io ho indicato nella costante E4 ma ovviamente da personalizzare in base alla
tua esigenza) è diversa da zero ed è un valore compreso tra iMin e iMax esegue un ciclo di ricalcolo del range dove sono presenti le formule.
Il ciclo continua fino a che non c'è corrispondenza tra la media dei valori ricalcolati nel range e la media prestabilita.
Viene però anche fissato un limite di cicli (anche questo da personalizzare) per uscire dal ciclo nel caso in cui la media dei valori presenti nel range non venisse trovata.
Questo per evitare che il ciclo continui all'infinito se la media dei valori presenti nel range non dovesse mai corrispondere alla media preimpostata.
Se vuoi prova la procedura in attesa di una risposta del buon Norman.
ciao
![](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)
