mercoledì 15 ottobre 2014

Arrotondamenti in VBA Excel

Me ne sono andato in crisi profondissima di fronte al modo in cui VBA Excel opera gli arrotondamenti.

Poi, andando in crisi, non riesco più a ragionare lucidamente, e non riuscendo a ragionare lucidamente me ne vado ancora più in crisi, fin quando collasso completamente e mi ci sento male da un punto di vista emotivo.
Meglio sempre razionalizzare per iscritto, altrimenti mi imprigiono dentro queste "strutture emotive patologiche" che mi paralizzano del tutto.

In fondo, è per questo che ho deciso di tenere un diario, solo che poi non lo compilo perché ho paura di essere troppo prolisso su argomenti banali e di appesantirlo.


Ecco.
Quello che mi serve è approssimare per difetto le frazioni da 0,1 a 0,4 e per eccesso quelle da 0.5 a 0.9.
Aiutandomi con spunti che ho trovato in rete, ecco la conclusione cui sono arrivato.
Mi creo un codice apposta per sperimentare la cosa.

Sub main()
    Dim n As Double
    For n = 1 To 5 Step 0.1
        Debug.Print n & " -----> " & Int(n + 0.5)
    Next n
End Sub
1 -----> 1
1,1 -----> 1
1,2 -----> 1
1,3 -----> 1
1,4 -----> 1
1,5 -----> 2
1,6 -----> 2
1,7 -----> 2
1,8 -----> 2
1,9 -----> 2
2 -----> 2
2,1 -----> 2
2,2 -----> 2
2,3 -----> 2
2,4 -----> 2
2,5 -----> 3
2,6 -----> 3
2,7 -----> 3
2,8 -----> 3
2,9 -----> 3
3 -----> 3
3,1 -----> 3
3,2 -----> 3
3,3 -----> 3
3,4 -----> 3
3,5 -----> 4
3,6 -----> 4
3,7 -----> 4
3,8 -----> 4
3,9 -----> 4
4 -----> 4
4,1 -----> 4
4,2 -----> 4
4,3 -----> 4
4,4 -----> 4
4,5 -----> 5
4,6 -----> 5
4,7 -----> 5
4,8 -----> 5
4,9 -----> 5
5 -----> 5
Sembra che risponda egregiamente ai miei piani. Era così banale, ma nel circolo vizioso in cui mi ero messo non ci avevo pensato: sono stato spiazzato dal metodo apparentemente assurdo di approssimazione che Excel opera, convertendo 0.5 ora nell'intero superiore ora in quello inferiore a seconda che la parte intera sia pari o dispari (Banker, pare che si chiami, ossia metodo "del banchiere"...)

Adesso applichiamolo alla bisogna.

Io ho un numero di turni da attribuire a due reparti che hanno rispettivamente un numero variabile di medici.
Faccio prima senza approssimazione:
Sub main()
    Dim turni As Integer
    Dim medCar As Integer, medMed As Integer
    Dim turniCar As Double, turniMed As Double
    Dim turniPerMedico As Double
    
    turni = 15
    medCar = 4
    medMed = 5
    
    turniPerMedico = turni / (medCar + medMed)
    
    turniCar = turniPerMedico * medCar
    turniMed = turniPerMedico * medMed
    
    Debug.Print turniCar
    Debug.Print turniMed
End Sub
 6,66666666666667 
 8,33333333333333 


Vario le cifre:
    medCar = 5
    medMed = 5
 7,5 
 7,5 



    medCar = 6
    medMed = 5
 8,18181818181818 
 6,81818181818182 


Adesso introduciamo un arrotondamento come quello che ho ricavato.

Sub main()
    Dim turni As Integer
    Dim medCar As Integer, medMed As Integer
    Dim turniCar As Double, turniMed As Double
    Dim turniPerMedico As Double
    
    turni = 15
    medCar = 4
    medMed = 5
    
    turniPerMedico = turni / (medCar + medMed)
    
    turniCar = Int(turniPerMedico * medCar + 0.5)
    turniMed = Int(turniPerMedico * medMed + 0.5)
    
    Debug.Print turniCar
    Debug.Print turniMed
End Sub
 7 
 8 



    medCar = 5
    medMed = 5
 8 
 8 



    medCar = 6
    medMed = 5
 8 
 7 


Facciamo un confronto con i risultati che avevo ottenuto senza approssimazione:
  1. Primo caso: 4 e 5:
    Senza arrotondamento:
     6,66666666666667 
     8,33333333333333 
    
    Con arrotondamento:
     7 
     8 
    somma: 15
    
    
  2. Secondo caso: 5 e 5:
    Senza arrotondamento:
     7,5 
     7,5 
    
    Con arrotondamento:
     8 
     8 
    somma:16
    
  3. Terzo caso: 6 e 5:
    Senza arrotondamento:
     8,18181818181818 
     6,81818181818182
    
    Con arrotondamento:
     8 
     7 
    somma:15
    


Solo nel caso in cui i due gruppi siano uguali, dal momento che la cifra decimale è 0.5, viene arrotondata in alto in ambedue, "creando" un turno in più: in tutti gli altri casi, essendo le cifre decimali diverse e necessariamente una al di sopra di 0.5 e l'altra al di sotto, i turni vengono divisi bene con l'arrotondamento, venendo attribuiti al gruppo cui ne "spetterebbe" la parte maggiore.


Dunque dal momento che l'unica situazione in cui la somma dei turni per reparto non corrisponde al totale dei turni pare sia questa, bisogna trovare un modo per normalizzare la cosa.

martedì 7 ottobre 2014

Arrotondamento dei turni teorici.

Ecco il piccolo codice che mi sono costruito per studiare le approssimazioni per difetto e per eccesso:
Sub main()
Dim cifraDouble As Double
Dim cifraInteger As Integer
cifraDouble = 1.4
cifraInteger = cifraDouble

Debug.Print ""
Debug.Print "Il valore della variabile Double è " & cifraDouble
Debug.Print "Valore della variabile double copiato in una variabile Integer " & cifraInteger
Debug.Print "Uso di Int " & Int(cifraDouble)
Debug.Print "Uso di CInt " & CInt(cifraDouble)
End Sub
Cambiando il valore di cifraDouble ottengo nella finestra immediata il valore ottenuto ponendo il valore in una variabile di tipo Integer o usando rispettivamente Int e CInt.
Il valore della variabile Double è 1,4
Valore della variabile double copiato in una variabile Integer 1
Uso di Int 1
Uso di CInt 1

Il valore della variabile Double è 1,5
Valore della variabile double copiato in una variabile Integer 2
Uso di Int 1
Uso di CInt 2

Il valore della variabile Double è 1,9
Valore della variabile double copiato in una variabile Integer 2
Uso di Int 1
Uso di CInt 2

Usare la variabile di tipo Integer o la parola chiave CInt ottiene gli stessi risultati, ossia arrotonda una cifra decimale fino a 0,5 di decimali all'intero inferiore, mentre la arrotonda se ha 0,5 o più di decimali all'intero superiore.
Invece Int arrotonda sempre per difetto, all'intero inferiore.
Per il mio programma sarà più conveniente usare CInt o porre il valore in una variabile di tipo Integer.


Resta il problema se c'è un numero uguale di elementi nei due gruppi.
Torno a considerare la cosa:
turni attribuiti card 17
turni attribuiti med 18
turni teorici card 18
turni teorici med 18
Ecco! Dal momento che ambedue le cifre in questo caso hanno 0.5 di decimali il numero viene arrotondato per eccesso in ambedue i turni, e si ha la "creazione" di un turno in più che non dovrebbe esserci.

Come risolvere la cosa?

La soluzione più giusta sarebbe risolvere la cosa a caso, togliendo casualmente un turno a uno dei due.
Dim turniTot As Integer
Dim medCar, medMed As Integer
Dim turniCar As Integer, turniMed As Integer
turniTot = k - 1 + f
medCar = 6
medMed = 6

turniCar = turniTot / (medCar + medMed) * medCar
turniMed = turniTot / (medCar + medMed) * medMed

If turniCar + turniMed > turniTot Then
    Dim estratto As Integer
    estratto = Int(Rnd() * 2)
    If estratto = 0 Then turniCar = turniCar - 1
    If estratto = 1 Then turniMed = turniMed - 1
End If
        
Debug.Print "turni teorici card " & turniCar
Debug.Print "turni teorici med " & turniMed
Così andiamo pure bene... ma diamo un'occhiata in diverse "estrazioni", nella finestra immediata, ai turni attribuiti e a quelli teorici ottenuti sottraendo a caso al numero falsamente gonfiato un turno:
turni attribuiti card 18
turni attribuiti med 17
turni teorici card 18
turni teorici med 17
turni attribuiti card 17
turni attribuiti med 18
turni teorici card 17
turni teorici med 18
turni attribuiti card 17
turni attribuiti med 18
turni teorici card 18
turni teorici med 17
...e mi rendo conto che una distribuzione "equa" era già stata fatta, in quanto il primo turno del mese era stato estratto casualmente mentre gli altri venivano in rigorosa alternanza.
Dunque non è il caso di andare avanti in elucubrazioni cervellotiche.
Basta fare che se il numero dei due gruppi è uguale non è necessario operare una correzione, e le cosa sono già sistemate da sé.

Calcolo dei turni teorici per reparto.

Ora devo conoscere, per fare i calcoli opportuni sulla scrittura dei turni alternati come ho fatto finora:
  • il numero totale dei turni disponibili
  • il numero dei medici di ciascun reparto
turniTot è il numero di turni totali disponibili.
medCar è il numero di medici della cardiologia.
medMed è il numero di medici della medicina.
turniCar è il numero di turni della cardiologia.
turniMed è il numero di turni della medicina.
turniTot / (medCar + medMed) = numero dei turni per ciascun medico.
Moltiplicando il numero di turni per ciascun medico per il numero di medici di ciascun reparto ottengo il numero di turni per ciascun reparto.

turniCar = turniTot / (medCar + medMed) * medCar

turniMed = turniTot / (medCar + medMed) * medMed
Calcoliamoli...
Sub main()
    Dim d As Date, nomeFoglio As String
    
    d = DateAdd("m", 1, Date)      'attribuisce alla variabile locale d il valore del mese successivo alla data attuale
    nomeFoglio = MonthName(Month(d)) & " " & Year(d)    'attribuisce alla stringa nomeFoglio mese e anno della variabile locale d
    
    Sheets.Add          'aggiunge un nuovo foglio
    On Error GoTo x     'gestisce l'errore di tentata rinominazione del foglio
    ActiveSheet.Name = nomeFoglio   'rinomina il foglio con la stringa nomeFoglio.
    ActiveSheet.Move after:=Sheets(Sheets.Count) 'sposta alla fine della cartella il nuovo foglio

        
    formattaFoglio Month(d), Year(d)  'formatta il foglio secondo lo schema
    attribuzioneTurni
    Exit Sub
x:     'gestione dell'errore di tentata rinominazione del foglio: elimina il foglio senza suscitare avvisi di eliminazione.
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

Private Sub attribuzioneTurni()
Dim reparti(1) As String
Dim n As Integer
Dim f As Integer
Dim tCar, tMed As Integer

reparti(0) = "CAR"
reparti(1) = "MED"
 
n = Int(Rnd() * 2)
Range("Reparto").Cells(1, 1).Formula = reparti(n)
If reparti(n) = "CAR" Then
    tCar = tCar + 1
Else
    tMed = tMed + 1
End If

For k = 2 To Range("Reparto").Rows.Count
    If n = 0 Then
        n = 1
    Else
        n = 0
    End If
    Range("Reparto").Cells(k, 1).Formula = reparti(n)
    If reparti(n) = "CAR" Then
        tCar = tCar + 1
    Else
        tMed = tMed + 1
    End If
    
    If festivo(Range("Reparto").Cells(k, 1).Offset(0, -2).Formula) Then
        If Range("Reparto").Cells(k, 1).Formula = "MED" Then
            Range("Reparto").Cells(k, 1).Formula = "CAR - MED"
            tCar = tCar + 1
        Else
            Range("Reparto").Cells(k, 1).Formula = "MED - CAR"
            tMed = tMed + 1
        End If
        f = f + 1
    End If
Next k
Debug.Print "turni attribuiti card " & tCar
Debug.Print "turni attribuiti med " & tMed


Dim turniTot As Integer
Dim medCar, medMed As Integer
Dim turniCar, turniMed As Integer
turniTot = k - 1 + f
medCar = 7
medMed = 6

turniCar = turniTot / (medCar + medMed) * medCar
turniMed = turniTot / (medCar + medMed) * medMed
Debug.Print "turni teorici card " & turniCar
Debug.Print "turni teorici med " & turniMed
End Sub
Risultato
turni attribuiti card 18
turni attribuiti med 17
turni teorici card 18,8461538461538
turni teorici med 16

Ecco, questo è il calcolo completo (quello marcato in rosso), ma c'è qualcosa che non va: il fatto che i turni siano espressi in una cifra decimale, essendo indivisibili.
Per giunta, la somma non combina, essendo espresso uno solo in frazioni di turno.
Sicuramente non sono appropriate le variabili che ho usato per immagazzinarne il valore.
Rifeccio:
Dim turniTot As Integer
Dim medCar, medMed As Integer
Dim turniCar, turniMed As Double
turniTot = k - 1 + f
medCar = 7
medMed = 6

turniCar = turniTot / (medCar + medMed) * medCar
turniMed = turniTot / (medCar + medMed) * medMed
Debug.Print "turni teorici card " & turniCar
Debug.Print "turni teorici med " & turniMed
Proviamo:
turni attribuiti card 17
turni attribuiti med 18
turni teorici card 18,8461538461538
turni teorici med 16,1538461538462
Perfetto! Si tratta di numeri periodici, per cui la verifica non darà mai il risultato esatto, comunque la somma fra i due mi restituisce 34,99999999..... che si può considerare esatto! I turni totali sono infatti 35.
Adesso dobbiamo vedere come liberarci delle frazioni di turno...
Intanto devo correggere un errore di codice che ho commesso: il motivo per cui uno dei risultati era frazionario e l'altro no è stato che io ho dichiarato le variabili in questo modo:
Dim turniCar, turniMed As Integer
credendo, in quanto non ricordavo bene questo aspetto della sintassi del VBA, che anche turniCar sarebbe stata dichiarata come Integer, mentre invece in realtà questa veniva dichiarata come Variant, e quindi mi dava un risultato decimale.
Correggendo la cosa...
Dim turniCar As Integer, turniMed As Integer
ottengo:
turni attribuiti card 17
turni attribuiti med 18
turni teorici card 19
turni teorici med 16
La somma è sempre 35, ma il risultato viene arrotondato.

Sarebbe il caso di vedere come VBA arrotonda... Mi costruisco un programmino dedicato.

Scrittura dei turni in forma alternata con riserva di modifica successiva

Ma forse mi conviene alternare, come ho fatto prima, per poi sostituire alcuni turni per far quadrare il conto.

L'algoritmo era questo:
Dim reparti(1) As String
Dim n As Integer
Dim f As Integer

reparti(0) = "CAR"
reparti(1) = "MED"
 
n = Int(Rnd() * 2)
Range("Reparto").Cells(1, 1).Formula = reparti(n)

For k = 2 To Range("Reparto").Rows.Count
    If n = 0 Then
        n = 1
    Else
        n = 0
    End If
    Range("Reparto").Cells(k, 1).Formula = reparti(n)
    If festivo(Range("Reparto").Cells(k, 1).Offset(0, -2).Formula) Then
        If Range("Reparto").Cells(k, 1).Formula = "MED" Then
            Range("Reparto").Cells(k, 1).Formula = "CAR - MED"
        Else
            Range("Reparto").Cells(k, 1).Formula = "MED - CAR"
        End If
        f = f + 1
    End If
Next k
in cui predispongo un array di due elementi stringa, "CAR" e "MED", quindi estraggo casualmente uno dei due e lo metto nella prima cella:
reparti(0) = "CAR"
reparti(1) = "MED"
 
n = Int(Rnd() * 2)
Range("Reparto").Cells(1, 1).Formula = reparti(n)
Quindi alterno la disposizione successiva in questo modo:
For k = 2 To Range("Reparto").Rows.Count
    If n = 0 Then
        n = 1
    Else
        n = 0
    End If
    Range("Reparto").Cells(k, 1).Formula = reparti(n)
Next k
Ossia prendo alternativamente i due elementi dell'array, "CAR" e "MED".

Per i festivi uso questo:
If festivo(Range("Reparto").Cells(k, 1).Offset(0, -2).Formula) Then
        If Range("Reparto").Cells(k, 1).Formula = "MED" Then
            Range("Reparto").Cells(k, 1).Formula = "CAR - MED"
        Else
            Range("Reparto").Cells(k, 1).Formula = "MED - CAR"
        End If
        f = f + 1
    End If
mettendo il giorno a CAR se la notte è MED e viceversa.
In tutto questo, sapendo il numero teorico di turni per CAR e MED, posso inserire un codice che conti i vari CAR e MED in modo da operare poi le sostituzioni nel modo opportuno.
Proviamo...
Private Sub attribuzioneTurni()
    Dim reparti(1) As String
    Dim n As Integer
    Dim f As Integer
    Dim tCar, tMed As Integer

    reparti(0) = "CAR"
    reparti(1) = "MED"
 
     n = Int(Rnd() * 2)
     Range("Reparto").Cells(1, 1).Formula = reparti(n)
    If reparti(n) = "CAR" Then
        tCar = tCar + 1
    Else
        tMed = tMed + 1
    End If

    For k = 2 To Range("Reparto").Rows.Count
        If n = 0 Then
            n = 1
        Else
            n = 0
        End If
        Range("Reparto").Cells(k, 1).Formula = reparti(n)
        If reparti(n) = "CAR" Then
            tCar = tCar + 1
        Else
            tMed = tMed + 1
        End If
    
        If festivo(Range("Reparto").Cells(k, 1).Offset(0, -2).Formula) Then
            If Range("Reparto").Cells(k, 1).Formula = "MED" Then
                Range("Reparto").Cells(k, 1).Formula = "CAR - MED"
                tCar = tCar + 1
            Else
                Range("Reparto").Cells(k, 1).Formula = "MED - CAR"
                tMed = tMed + 1
            End If
            f = f + 1
        End If
    Next k
    Debug.Print "turni card " & tCar
    Debug.Print "turni med " & tMed

End Sub
Ecco: le aggiunte contrassegnate in rosso su giallo sono quelle che ho fatto per contare i turni CAR e i turni MED del mese.
Ho contrassegnato peraltro in bianco su blu una variabile che mi serve per contare il numero dei festivi e aggiungerlo al numero delle celle in modo da avere il totale dei turni disponibili.

Distribuzione casuale dei turni.

Questo è un modo di distribuire casualmente un numero num di contenuti di una cella in modo casuale all'interno di un range formato da numTot celle.
Sub main()
Dim num, numTot, contatore As Integer

    num = 13
    numTot = 30
    contatore = 0
    Do While contatore < num
        k = 1 + Int(Rnd() * numTot)
            If Range(Cells(1, 1), Cells(numTot, 1)).Cells(k, 1).Formula = "" Then
                Range(Cells(1, 1), Cells(numTot, 1)).Cells(k, 1).Formula = "CAR"
                contatore = contatore + 1
            End If
    Loop
End Sub
La distribuzione è assolutamente casuale.