Riscrivi questo listato Option Explicit

Dim wsOdierno As Worksheet
Dim wsAnalyze As Worksheet
Dim wsData As Worksheet
Dim wsStorico As Worksheet

Sub ToggleApplicationSettings(ByVal enable As Boolean)
    Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    Application.ScreenUpdating = enable
    Application.EnableEvents = enable
End Sub

Sub Analyze_Data()
    Dim myRanges() As Range

    ToggleApplicationSettings False

    Set wsOdierno = ThisWorkbook.Worksheets("Odierno")
    Set wsAnalyze = ThisWorkbook.Worksheets("Analyze")
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsStorico = ThisWorkbook.Worksheets("Storico")

    CreateRanges myRanges
    Elabora_Dati myRanges
    StoricizzaDatieVar

    ToggleApplicationSettings True
End Sub

Sub CreateRanges(ByRef myRanges() As Range)
    Dim rangeAddresses As Variant
    Dim i As Integer

    rangeAddresses = Array("E12:E49,E51:E62,E64:E81,E84:E96,E98:E111", _
                           "F12:F49,F51:F62,F64:F81,F84:F96,F98:F111", _
                           "G12:G49,G51:G62,G64:G81,G84:G96,G98:G111", _
                           "H12:H49,H51:H62,H64:H81,H84:H96,H98:H111", _
                           "I12:I49,I51:I62,I64:I81,I84:I96,I98:I111")
    ReDim myRanges(1 To 5)

    For i = 1 To 5
        Set myRanges(i) = wsOdierno.Range(rangeAddresses(i - 1))
    Next i
End Sub

Sub Elabora_Dati(ByRef myRanges() As Range)
    Dim i As Integer
    Dim analyzeRange As Range

    ' Imposta il range per l'analisi
    Set analyzeRange = wsAnalyze.Range("D13")
    
    For i = 2 To 6
        CopiaRange myRanges(i - 1), analyzeRange
        AnalyzeOnly
        Sheets("VAR").Cells(26, i).Resize(11).Value = Application.Transpose(Sheets("Analyze").Range("F10:P10").Value)
    Next i
End Sub

Sub StoricizzaDatieVar()
    Dim myMultiAreaPrice As Range
    Dim wsVAR As Worksheet
    Dim wsDestinations As Variant
    Dim col As Integer
    Dim lastRows As Variant
    Dim sourceData As Variant
    Dim destCell As Range

    ToggleApplicationSettings False

    Set wsVAR = ThisWorkbook.Worksheets("VAR")
    Set wsStorico = ThisWorkbook.Worksheets("Storico")

    ' Copia dati di sicurezza ed immagazzina dati chiusi precedenti
    wsVAR.Range("R22:V24").Value = wsVAR.Range("B22:F24").Value

    ' Incolla su Foglio Data
    CopiaRange wsOdierno.Range("A10:A49,A51:A62,A64:A81,A84:A96,A98:A111"), wsData.Range("A1").End(xlDown).Offset(1, 0)

    ' Incolla su Foglio Storico
    sourceData = wsOdierno.Range("A9:A111").Value
    Set destCell = wsStorico.Range("A10").End(xlDown).Offset(1, 0)
    destCell.Resize(UBound(sourceData, 2), UBound(sourceData, 1)).Value = Application.Transpose(sourceData)

    ' Incolla su altri fogli
    wsDestinations = Array("Cass", "Tr", "Tot", "BCC", "Gen")
    lastRows = Array(52, 52, 52, 52, 60) ' Colonna 6 ha 60 righe, le altre 52

    OrdinaVAR

    For col = 11 To 15
        CopiaRange wsVAR.Range(wsVAR.Cells(3, col), wsVAR.Cells(lastRows(col - 11), col)), _
                   ThisWorkbook.Sheets(wsDestinations(col - 11)).Range("A10").End(xlDown).Offset(1, 0)
    Next col

    ' Copia dati di sicurezza
    wsVAR.Range("R61:V68").Value = wsVAR.Range("B61:F68").Value
    wsVAR.Range("B61:F68").Value = wsVAR.Range("B53:F60").Value

    ' Riabilita aggiornamenti e eventi
    ToggleApplicationSettings True
    Sheets("Gen").Select
End Sub

Sub OrdinaVAR()
    Dim ws As Worksheet
    Dim lookupRange As Range
    Dim foundCell As Range
    Dim rowIndex As Long
    Dim i As Long
    Dim azione As String
    Dim sourceValues As Variant
    Dim sourceFormats As Variant
    Dim destRange As Range
    Dim j As Integer
    Dim cell As Range

    ' Imposta il foglio di lavoro VAR
    Set ws = ThisWorkbook.Sheets("VAR")

    ' Definisce l'intervallo di ricerca per il valore di lookup (G3:G52)
    Set lookupRange = ws.Range("G3:G52")

    ' Imposta l'indice di riga di destinazione iniziale
    rowIndex = 3 ' Supponendo che la destinazione inizi dalla riga 3

    With ws
        ' Ciclo principale attraverso le righe 3 a 52
        For i = 3 To 52
            ' Ottiene il valore di lookup dalla colonna H (8)
            Dim lookupValue As Variant
            lookupValue = .Cells(i, "H").Value ' H3:H52

            ' Definisce l'intervallo di destinazione nella riga corrente
            Set destRange = .Range("J" & rowIndex & ":O" & rowIndex)

            ' Verifica se ci sono celle unite e le scompatta
            If destRange.MergeCells Then
                destRange.UnMerge
            End If

            ' Cerca il valore di lookup nell'intervallo di ricerca
            Set foundCell = lookupRange.Find(What:=lookupValue, LookIn:=xlValues, LookAt:=xlWhole)

            If Not foundCell Is Nothing Then
                ' Copia i valori
                sourceValues = .Range("A" & foundCell.Row & ":F" & foundCell.Row).Value

                ' Verifica le dimensioni
                If UBound(sourceValues, 1) = destRange.Rows.Count And _
                   UBound(sourceValues, 2) = destRange.Columns.Count Then
                       destRange.Value = sourceValues
                Else
                    ' Gestisci la discrepanza
                    Debug.Print "Mismatch nelle dimensioni per rowIndex " & rowIndex
                    destRange.ClearContents
                End If

                ' Copia i formati
                sourceFormats = .Range("A" & foundCell.Row & ":F" & foundCell.Row).NumberFormat
                If IsArray(sourceFormats) Then
                    For j = 1 To UBound(sourceFormats, 2)
                        SetNumberFormatSafely destRange.Cells(1, j), sourceFormats(1, j)
                    Next j
                Else
                    ' Se sourceFormats è una stringa, applica lo stesso formato a tutte le celle
                    SetNumberFormatSafely destRange, sourceFormats
                End If
            Else
                ' Se non trovato, svuota l'intervallo di destinazione
                destRange.ClearContents
            End If

            ' Determina l'azione da eseguire basata sulla colonna I
            Select Case UCase(Trim(.Cells(i, "I").Value))
                Case "B"
                    azione = "ARROTONDA_1000"
                Case "C"
                    azione = "ARROTONDA_4"
                Case "D"
                    azione = "ARROTONDA_100"
                Case Else
                    azione = "NESSUNA"
            End Select

            ' Chiama la subroutine per gestire gli arrotondamenti
            Call GestisciArrotondamenti(destRange, azione)

            ' Incrementa l'indice di riga di destinazione per la prossima iterazione
            rowIndex = rowIndex + 1

            ' Verifica che rowIndex non superi il numero di righe del foglio
            If rowIndex > ws.Rows.Count Then
                MsgBox "Riga di destinazione supera il limite del foglio.", vbCritical
                Exit Sub
            End If
        Next i

        ' Copia i valori e i formati da F53:F60 a O53:O60 senza usare Copy/PasteSpecial
        .Range("O53:O60").Value = .Range("F53:F60").Value
        For j = 1 To .Range("F53:F60").Rows.Count
            SetNumberFormatSafely .Range("O53:O60").Cells(j, 1), .Range("F53:F60").Cells(j, 1).NumberFormat
        Next j

        ' Aggiorna i dati di sicurezza (backup) senza usare Copy/PasteSpecial
        .Range("R22:V24").Value = .Range("B22:F24").Value
        .Range("B61:F68").Value = .Range("B53:F60").Value
    End With

    ' Pulisce gli appunti per evitare messaggi di avviso
    Application.CutCopyMode = False
End Sub

Sub GestisciArrotondamenti(destRange As Range, azione As String)
    Dim cell As Range

    For Each cell In destRange
        If IsNumeric(cell.Value) Then
            Select Case azione
                Case "ARROTONDA_1000"
                    If cell.Value > 1000 Then
                        cell.Value = Application.WorksheetFunction.MRound(cell.Value, 1000)
                    End If
                Case "ARROTONDA_4"
                    cell.Value = Application.WorksheetFunction.Round(cell.Value, 4)
                Case "ARROTONDA_100"
                    If cell.Value > 100 Then
                        cell.Value = Application.WorksheetFunction.MRound(cell.Value, 100)
                    End If
            End Select
        End If
    Next cell
End Sub

Sub CopiaRange(sorgente As Range, destinazione As Range)
    ' Copia i valori
    destinazione.Value = sorgente.Value
    
    ' Copia i formati
    Dim i As Long
    For i = 1 To sorgente.Count
        SetNumberFormatSafely destinazione.Cells(i), sorgente.Cells(i).NumberFormat
    Next i
End Sub

Private Sub SetNumberFormatSafely(targetCell As Range, format As Variant)
    On Error Resume Next
    targetCell.NumberFormat = format
    If err.Number <> 0 Then
        targetCell.NumberFormat = "General"
        err.Clear
    End If
    On Error GoTo 0
End Sub  eliminando la ripetizione dell'assegnazione delle variabili worksheet in diverse subroutine. Dichiara le variabili worksheet a livello di modulo e inizializzarle una sola volta, ad esempio nella subroutine Analyze_Data:

Option Explicit

Dim wsOdierno As Worksheet, wsAnalyze As Worksheet, wsData As Worksheet, wsStorico As Worksheet, wsVAR As Worksheet

Sub Analyze_Data()
    '...
    Set wsOdierno = ThisWorkbook.Worksheets("Odierno")
    Set wsAnalyze = ThisWorkbook.Worksheets("Analyze")
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsStorico = ThisWorkbook.Worksheets("Storico")
    Set wsVAR = ThisWorkbook.Worksheets("VAR") ' Inizializza anche wsVAR qui
    '...
End Sub

Sub StoricizzaDatieVar()
   '...
   ' Le variabili wsVAR e wsStorico sono già inizializzate
   ' Non è necessario reinizializzarle
   '...
End Sub  e verifica in ogni sub la eventualita' di chiamare Analyze Data