vba excel Archivi - Petar Karan

18 Settembre 2018 Nessun commento

[vba] Creare una funzione che accetti un numero indefinito di parametri

Per questo esercizio vediamo come creare una funzione personalizzata simile (perché non andremo ad implementare tutte le alternative) al SOMMA.PIÙ.SE in VBA per Excel.

Anzitutto individuiamo le criticità:

Avremo bisogno di accettare un range per la somma ed n coppie di parametri come intervalli e criteri, la nostra funzione avrà quindi la forma di FUNZIONE(somma, [intervallo 1], [criterio 1], …)
I criteri possono essere numerici oppure stringhe di confronto, come per esempio “>2”

Anzitutto vediamo come creare una funzione che accetti n parametri come abbiamo definito di sopra. Per cui digitiamo in VBA:

Function SOMMAPIUSE(ByVal somma As Range, ParamArray args() As Variant) As Double

    Dim totale As Double
    
    totale = 0
    
    SOMMAPIUSE = totale

End Function

Function SOMMAPIUSE(ByVal somma As Range, ParamArray args() As Variant) As Double

Dim totale As Double

totale = 0

SOMMAPIUSE = totale

End Function

In questo caso abbiamo inserito il minimo indispensabile, definendo il risultato come un Double, dichiarando internamente una variabile totale ed impostandola su 0. Questa variabile la utilizzeremo in seguito. L’argomento somma è di tipo Range (qui occhio agli indici, come vedremo tra poco!) e poi segue un vettore di parametri args definiti come Variant.

Per scorrere i vari parametri possiamo usare l’istruzione:

For i = LBound(args) To UBound(args)
    ' qui le nostre operazioni su args(i) 
Next i

For i = LBound(args) To UBound(args)

' qui le nostre operazioni su args(i)

Next i

A questo punto vogliamo costruire un vettore di criteri lungo quanto l’intervallo della somma e che per ogni chiave contenga un valore equivalente a 0 oppure ad 1, in funzione che si debba o meno sommare il valore nell’intervallo somma.

Per fare questo definiamo:

Dim criteri() As Variant
Dim max, count As Integer
    
max = somma.count
    
ReDim criteri(max)
    
For i = 0 To max - 1
    criteri(i) = 1
Next i

Dim criteri() As Variant

Dim max, count As Integer

max = somma.count

ReDim criteri(max)

For i = 0 To max - 1

criteri(i) = 1

Next i

Con il metodo somma.count misuriamo la dimensione del Range somma, attenzione perché il range si muove da 1 fino a somma.count, mentre il nostro vettore criteri andrà da 0 fino a somma.count – 1

Infine impostiamo tutto il vettore criteri() su 1, questo ci servirà tra poco per le operazioni logiche.

A questo punto non ci rimane che valutare tutti i criteri, tenendo presente che vanno a coppie di intervallo criteri e criterio. Perciò utilizzeremo l’istruzione:

If i Mod 2 = 0 Then

End If

If i Mod 2 = 0 Then

End If

Gli intervalli dei criteri si trovano in posizioni pari, mentre il criterio in posizione dispari.

Infine utilizzeremo il metodo Evaluate sfruttando la funzione SE di Excel per valutare ogni criterio, nel modo seguente:

Evaluate("IF(" & a.Value & "=" & args(i + 1) & ",1,0)")

1	Evaluate("IF(" & a.Value & "=" & args(i + 1) & ",1,0)")

Faccio notare che in Evaluate va scritta la funzione col nome in inglese. Dal momento che i criteri possono essere numerici oppure stringhe, come abbiamo detto all’inizio, dobbiamo distinguere tra le due cose e quindi scriveremo:

If IsNumeric(args(i + 1)) Then
    '... valore tipo 1, 2 ecc
Else
    '... valore tipo >2, <=4 ecc
End If

If IsNumeric(args(i + 1)) Then

'... valore tipo 1, 2 ecc

Else

'... valore tipo >2, <=4 ecc

End If

Infine ricordiamoci che tutti i criteri devono essere validi, quindi per modificare ogni posizione del vettore criteri() useremo il prodotto. In questo modo se sono tutti veri risulterà 1, un prodotto di tutti 1 insomma, mentre se anche un solo criterio sarà falso allora il prodotto risulterà 0, dal momento che basta uno 0 nel prodotto per azzerare tutto.

Detto tutto ciò la nostra funzione finale sarà simile a questa:

Function SOMMAPIUSE(ByVal somma As Range, ParamArray args() As Variant) As Double

    Dim totale As Double
    Dim criteri() As Variant
    Dim max, count As Integer
    
    max = somma.count
    
    ReDim criteri(max)
    
    For i = 0 To max - 1
        criteri(i) = 1
    Next i
    
    totale = 0
    
    For i = LBound(args) To UBound(args)
        If i Mod 2 = 0 Then
            
            count = 0
            
            For Each a In args(i)
                                
                If count < max Then
                    If IsNumeric(args(i + 1)) Then
                        criteri(count) = criteri(count) * Evaluate("IF(" & a.Value & "=" & args(i + 1) & ",1,0)")
                    Else
                        criteri(count) = criteri(count) * Evaluate("IF(" & a.Value & args(i + 1) & ",1,0)")
                    End If
                End If
                
                count = count + 1
                
            Next a
            
        End If
    Next i
    
    For i = 0 To max - 1
        If criteri(i) = 1 Then
            totale = totale + somma(i + 1)
        End If
    Next i
    
    SOMMAPIUSE = totale

End Function

Function SOMMAPIUSE(ByVal somma As Range, ParamArray args() As Variant) As Double

Dim totale As Double

Dim criteri() As Variant

Dim max, count As Integer

max = somma.count

ReDim criteri(max)

For i = 0 To max - 1

criteri(i) = 1

Next i

totale = 0

For i = LBound(args) To UBound(args)

If i Mod 2 = 0 Then

count = 0

For Each a In args(i)

If count < max Then

If IsNumeric(args(i + 1)) Then

criteri(count) = criteri(count) * Evaluate("IF(" & a.Value & "=" & args(i + 1) & ",1,0)")

Else

criteri(count) = criteri(count) * Evaluate("IF(" & a.Value & args(i + 1) & ",1,0)")

End If

count = count + 1

Next a

End If

Next i

For i = 0 To max - 1

If criteri(i) = 1 Then

totale = totale + somma(i + 1)

End If

Next i

SOMMAPIUSE = totale

End Function

Inutile dire che la funzione potrebbe essere ulteriormente affinata per coprire tutti i possibili casi in cui può essere utilizzata SOMMA.PIÙ.SE 😉

Vedi articolo

15 Febbraio 2018 3 commenti

Interrogare foglio di Excel con SQL in VBA

Obiettivo: interrogare e filtrare il contenuto di un foglio excel come se fosse una tabella di un database SQL

Prepariamo anzitutto un file Excel creando un foglio con dei dati come quelli di seguito:

Questo foglio lo chiamiamo DATI. Faccio notare che nella prima riga ho inserito le intestazioni della nostra tabella.

In un secondo foglio andiamo a creare un pulsante che richiamerà un form. L’idea sarebbe quella di creare un metodo di inserimento che guidi l’utente e gli permetta di filtrare una vasta base dati, eseguendo anche dei comandi di ricerca. Il risultato sarà il seguente:

Se proviamo a cercare qualcosa, per esempio “Mar” l’elenco dovrà essere filtrato e otterremo il risultato seguente:

Fatte queste premesse vediamo come realizzare l’interrogazione del foglio mediante VBA (sorvolo sull’elementare creazione del form).

Anzitutto creiamo una Sub che caricherà i valori nella combobox (cmbSeleziona) e nella listbox (lbSeleziona).

Private Sub LoadSelect(Optional ByVal nome As String = "")

    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strFileName As String
    Dim ConnectionString As String
    
    strFileName = ThisWorkbook.FullName
    
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & strFileName & ";Extended Properties=""Excel 12.0 xml;HDR=YES;IMEX=1;Readonly=True"";"
    
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    conn.Open ConnectionString
    
    Dim query As String
    
    If nome <> "" Then
        query = "SELECT * FROM [DATI$A:C] WHERE Nome LIKE '%" & nome & "%'"
    Else
        query = "SELECT * FROM [DATI$A:C]"
    End If
    
    rs.Open query, conn
    
    cmbSeleziona.Clear
    lbSelezione.Clear
    
    pos = 0
    
    If Not rs.EOF Then
        Do
            
            cmbSeleziona.AddItem rs(1) & " [" & rs(2) & "]", pos
            cmbSeleziona.List(pos, 1) = rs(0)
            
            lbSelezione.AddItem rs(1) & " [" & rs(2) & "]", pos
            lbSelezione.List(pos, 1) = rs(0)
            
            pos = pos + 1
            rs.MoveNext
        Loop Until rs.EOF
    End If
    
    rs.Close
    
    conn.Close

End Sub

Private Sub LoadSelect(Optional ByVal nome As String = "")

Dim conn As ADODB.Connection

Dim rs As ADODB.Recordset

Dim strFileName As String

Dim ConnectionString As String

strFileName = ThisWorkbook.FullName

ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _

& strFileName & ";Extended Properties=""Excel 12.0 xml;HDR=YES;IMEX=1;Readonly=True"";"

Set conn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

conn.Open ConnectionString

Dim query As String

If nome <> "" Then

query = "SELECT * FROM [DATI$A:C] WHERE Nome LIKE '%" & nome & "%'"

Else

query = "SELECT * FROM [DATI$A:C]"

End If

rs.Open query, conn

cmbSeleziona.Clear

lbSelezione.Clear

pos = 0

If Not rs.EOF Then

cmbSeleziona.AddItem rs(1) & " [" & rs(2) & "]", pos

cmbSeleziona.List(pos, 1) = rs(0)

lbSelezione.AddItem rs(1) & " [" & rs(2) & "]", pos

lbSelezione.List(pos, 1) = rs(0)

pos = pos + 1

rs.MoveNext

Loop Until rs.EOF

End If

rs.Close

conn.Close

End Sub

Faccio notare che in questo caso la query filtra solamente i valori in base al Nome, inoltre il parametro nome può essere passato in via opzionale, permettendo quindi anche di visualizzare tutti i campi se non c’è nessun nome da filtrare.

Ricordiamoci che per poter eseguire la connessione ADO abbiamo bisogno di importare l’opportuna libreria dai riferimenti.

A questo punto completiamo il nostro codice aggiungendo:

Private Sub txtCerca_Change()

    LoadSelect txtCerca.Text

End Sub

Private Sub UserForm_Initialize()

    LoadSelect

End Sub

Private Sub txtCerca_Change()

LoadSelect txtCerca.Text

End Sub

Private Sub UserForm_Initialize()

LoadSelect

End Sub

In questo modo ad ogni modifica (change) di txtCerca, che è la textbox di ricerca in cima al form, verrà interrogato il nostro foglio per produrre un risultato.

Il medesimo metodo LoadSelect, questa volta senza argomenti, lo aggiungiamo anche all’avvio del form, per caricare il contenuto completo senza filtri.

Qui è possibile scaricare il file creato con Excel 2016.

Vedi articolo

28 Gennaio 2018 Nessun commento

Calcolare IRR (Internal Rate of Return o TIR.COST) in VBA

Problema: la funzione TIR.COST (Tasso Interno di Rendimento) restituisce un unico valore per l’IRR anche quando ce ne è più di uno

Senza discutere sull’interpretazione dell’IRR stesso, immaginiamo di avere i seguenti due scenari di flusso di cassa.

I Scenario

Questo produce un grafico VAN-IRR come quello seguente:

In questo caso abbiamo due valori dell’IRR rispettivamente 15,47% e 33,33%; la funzione TIR.COST restituisce solamente il primo valore.

II Scenario

A questa serie di flussi di cassa corrisponde il seguente grafico:

In questo caso abbiamo due valori dell’IRR rispettivamente 1,99% e 19,65%; la funzione TIR.COST restituisce solamente il secondo valore.

Costruiamo quindi in VBA le funzioni necessarie per effettuare questo calcolo; come già mostrato anche qui utilizzeremo una funzione che restituisca un vettore di valori sotto forma di Variant, in modo da poterli valutare singolarmente (per esempio utilizzando le funzioni MIN e MAX, quando i valori sono solo due, quindi =MIN(IRRX(A1:A10)) oppure =MAX(IRRX(A1:A10))).

La funzione finale si chiama IRRX, quella che utilizzeremo dentro il foglio excel.

Public Function IRRX(ByVal intervallo As Range, Optional ByVal max As Double = 300) As Variant

    Dim n As Integer
    Dim i As Double
    Dim irrs, ris As Variant
    irrs = IRRv1(intervallo, 0.01, max)
    
    ReDim ris(1 To 1)
    
    n = 0
    
    For k = 1 To UBound(irrs)
    
        i = irrs(k)
        
        Dim tmp As Variant
        tmp = IRRv2(intervallo, i - 0.01, i + 0.01)
        n = n + 1
        
        ReDim Preserve ris(1 To n)
        
        ris(n) = tmp
    
    Next k
    
    IRRX = ris

End Function

Private Function IRRv1(ByVal intervallo As Range, Optional ByVal delta As Double = 0.01, Optional ByVal max As Double = 300, Optional ByVal start As Double = 0) As Variant

    Dim irrs As Variant
    Dim VAN, VAN_prec, tir_prec As Double
    Dim anno, nirr As Integer
    
    ReDim irrs(1 To 1)
    
    nirr = 0
    
    For tir = start To max Step delta
        
        VAN = 0
        anno = 0
        
        For Each c In intervallo
        
            VAN = VAN + c.Value / (1 + tir) ^ anno
            
            anno = anno + 1
        
        Next c
        
        If tir > start And VAN_prec * VAN <= 0 Then
            
            nirr = nirr + 1
            
            ReDim Preserve irrs(1 To nirr)
            irrs(nirr) = (tir + tir_prec) / 2
            
        End If
        
        VAN_prec = VAN
        tir_prec = tir
        
    Next tir
    
    IRRv1 = irrs

End Function

Private Function IRRv2(ByVal flusso As Range, ByVal min As Double, ByVal max As Double) As Double

    For i = 0 To 100
    
        tmin = VAN(flusso, min)
        tmax = VAN(flusso, max)
        tavg = VAN(flusso, (max + min) / 2)
        
        If tavg = 0 Then
            Exit For
        End If
        
        If tmin * tavg < 0 Then
            max = (max + min) / 2
        Else
            min = (max + min) / 2
        End If
        
    Next i
    
    IRRv2 = (max + min) / 2

End Function

Private Function VAN(ByVal intervallo As Range, ByVal tir As Double) As Double

    Dim tmp As Double
    Dim anno As Integer
    
    tmp = 0
    anno = 0
    
    For Each c In intervallo
        
        tmp = tmp + c.Value / (1 + tir) ^ anno
        
        anno = anno + 1
    
    Next c
    
    VAN = tmp

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

Public Function IRRX(ByVal intervallo As Range, Optional ByVal max As Double = 300) As Variant

Dim n As Integer

Dim i As Double

Dim irrs, ris As Variant

irrs = IRRv1(intervallo, 0.01, max)

ReDim ris(1 To 1)

n = 0

For k = 1 To UBound(irrs)

i = irrs(k)

Dim tmp As Variant

tmp = IRRv2(intervallo, i - 0.01, i + 0.01)

n = n + 1

ReDim Preserve ris(1 To n)

ris(n) = tmp

Next k

IRRX = ris

End Function

Private Function IRRv1(ByVal intervallo As Range, Optional ByVal delta As Double = 0.01, Optional ByVal max As Double = 300, Optional ByVal start As Double = 0) As Variant

Dim irrs As Variant

Dim VAN, VAN_prec, tir_prec As Double

Dim anno, nirr As Integer

ReDim irrs(1 To 1)

nirr = 0

For tir = start To max Step delta

VAN = 0

anno = 0

For Each c In intervallo

VAN = VAN + c.Value / (1 + tir) ^ anno

anno = anno + 1

Next c

If tir > start And VAN_prec * VAN <= 0 Then

nirr = nirr + 1

ReDim Preserve irrs(1 To nirr)

irrs(nirr) = (tir + tir_prec) / 2

End If

VAN_prec = VAN

tir_prec = tir

Next tir

IRRv1 = irrs

End Function

Private Function IRRv2(ByVal flusso As Range, ByVal min As Double, ByVal max As Double) As Double

For i = 0 To 100

tmin = VAN(flusso, min)

tmax = VAN(flusso, max)

tavg = VAN(flusso, (max + min) / 2)

If tavg = 0 Then

Exit For

End If

If tmin * tavg < 0 Then

max = (max + min) / 2

Else

min = (max + min) / 2

End If

Next i

IRRv2 = (max + min) / 2

End Function

Private Function VAN(ByVal intervallo As Range, ByVal tir As Double) As Double

Dim tmp As Double

Dim anno As Integer

tmp = 0

anno = 0

For Each c In intervallo

tmp = tmp + c.Value / (1 + tir) ^ anno

anno = anno + 1

Next c

VAN = tmp

End Function

Le altre funzioni servono rispettivamente a:

IRRv1 – calcolare in modo approssimativo tutti gli IRR possibili su uno specifico flusso di cassa, con valore massimo per l’IRR al 30.000% (espresso come max = 300), inutile dire come questo valore possa essere impostato anche a molto meno per velocizzare i calcoli; l’IRR qui viene calcolato per ogni punto percentuale con scarti del 1%
IRRv2 – qui calcoliamo, per ogni valore di IRR trovato con la precedente funzione, il valore approssimato mediante iterazione su valori che vanno da IRRv2 ± 1%
VAN – questa funziona calcola semplicemente il VAN sul dato IRR

Testato su Excel 2016.

Vedi articolo