Funcţie Custom Made Excel VBA: Distanţa Medie Alergată Lunar

Am descoperit mai demult un mic bug la aplicaţia mea de alergare pe care am postat-o şi pe blog aici. Mai exact, în sheet-ul "Years Comparison", la calcularea distanţei medii lunare, într-o singură situaţie rezultatul nu era corect: când în luna în curs nu aveam nicio alergare.

Dar haideţi să vedem exact care a fost problema ce trebuia rezolvată şi care este rezolvarea mea:

După cum puteţi vedea şi în imaginea din dreapta care se poate mări apăsând pe ea, avem o bază de date cu alergările fiecărui user din aplicaţie. (în acest exemplu, doar eu :) ). 

Am dorit să calculez Distanţa Medie lunară alergată ţinând cont de următoarele criterii:

      - se iau în considerare doar lunile în care am alergat cel puţin 1 km. Daca într-o lună nu am alergat deloc se exclude din calcularea mediei. Mai exact vreau să văd media doar în lunile în care am alergat;

        -  se iau în calcul doar distanţele alergate în luni terminate, nu şi cele din luna în curs. De exemplu, daca în lunile Ianuarie, Februarie şi Martie am alergat câte 100 de km, iar azi suntem în 1 Aprilie şi am alergat 2 km, nu trebuie să ne păcălim calculând media ca (100+100+100+2)/4 = 75.5 km lunar, deoarece rezultatul nu este corect. Trebuie să calculăm doar pentru lunile încheiate, deci în  acest exemplu media ar fi (100+100+100)/3= 100 km lunar. 

           -   trebuie să putem calcula media automat, pe fiecare an, tip de alergare şi user. Mai precis, dacă în imaginea din dreapta selectăm un alt tip de activitate sau un alt user media trebuie să se modifice, iar daca avem alergari şi în alţi ani, pe coloana anului respectiv trebuie să apară distanţa medie alergată. 

Iniţial am combinat o mulţime de funcţii Excel şi am ajuns la o formulă lungă cât o zi de post şi care nu arăta deloc bine şi în plus era şi foarte dificil de corectat. Arăta cam aşa:

De mai demult am avut ideea de a crea o User Defined Function care să arate mai "omenesc" şi să calculeze mai eficient şi mai corect, însă abia astăzi mi-am făcut timp şi chef să o creez şi să o postez pe blog pentru cei interesaţi de subiect.

Funcţia are 3 argumente obligatorii: anul, tipul alergării şi userul şi se introduce în bara de formule a Excel-ului, la fel ca funcţiile predefinite:

Cum funcţionează ?


Puteţi descărca fişierul Excel apăsând AICI.

Funcţia este creată folosind Excel VBA, iar codul care face toate calculele este cel de mai jos.

Cu siguranţă sunt şi alte metode de rezolvare a acestei probleme, deci dacă ai o idee mai bună, te rog să scrii un comentariu.

Function MonthlyDstAverage(selyear As Long, seltype As String, seluser As String) As Double

Application.Volatile True

iyear = year(Date) ' current year
Set ws = ThisWorkbook.Sheets("Data Base")

'Find the lastrow from sheet data base
If ws.Range("A4") = "" Then
lastrow = 1
Else: lastrow = ws.Range("A3").End(xlDown).Row
End If

'if the selected year is in future then the average is 0 because we cannot have runs in future
While iyear < selyear
MonthlyDstAverage = 0
Exit Function
Wend
    
cmonth = Month(Date)  'the current month

monthswithruns = 0     'months when we ran more than 0 kilometers
cmonthruns = cmonth    'the lastmonth used for calculating the average. If we ran in current month min once, the lastmonth will be current month minus 1

'-----------------------CALCULATE----------------------------------
'if the selected type of runs is All then calculate monthly average
Select Case seltype

Case "All"

'calculate the number of months with runs
   For i = 1 To cmonth
    
        If Application.WorksheetFunction.CountIfs(ws.Range("K:K"), selyear, ws.Range("J:J"), i, ws.Range("C:C"), seluser) > 0 Then
        monthswithruns = monthswithruns + 1
        End If

    Next i
    
'calculate number of runs from current month and if we ran min once then subsctract one month

        If Application.WorksheetFunction.CountIfs(ws.Range("K:K"), selyear, ws.Range("J:J"), cmonth, ws.Range("C:C"), seluser) > 0 Then
        monthswithruns = monthswithruns - 1
        cmonthruns = cmonth - 1
        End If
    
'calculate distance ran in interval matching selected criteria
    randst = 0
    For j = 1 To lastrow
        For k = 1 To cmonthruns
    
            If ws.Cells(j, 11) = selyear And ws.Cells(j, 10) = k And ws.Cells(i, 3) = seluser Then
            randst = randst + ws.Cells(j, 4).Value
            End If
        Next k
    Next j

    MonthlyDstAverage = randst / monthswithruns
'--------------------------------------------------------------------------
'if the selected type is different then All then calculate monthly average including the criteria with run type
Case Else

    'calculate the number of months with runs
    For i = 1 To cmonth
    
    If Application.WorksheetFunction.CountIfs(ws.Range("K:K"), selyear, ws.Range("J:J"), i, ws.Range("G:G"), seltype, ws.Range("C:C"), seluser) > 0 Then
        monthswithruns = monthswithruns + 1
    End If

    Next i
    
    'calculate number of runs from current month and if we ran min once then subsctract one month
        If Application.WorksheetFunction.CountIfs(ws.Range("K:K"), selyear, ws.Range("J:J"), cmonth, ws.Range("G:G"), seltype, ws.Range("C:C"), seluser) > 0 Then
        monthswithruns = monthswithruns - 1
        cmonthruns = cmonth - 1
        End If
    
    'calculate distance ran in interval matching selected criteria
    randst = 0
    For j = 1 To lastrow
        For k = 1 To cmonthruns
    
            If ws.Cells(j, 11) = selyear And ws.Cells(j, 10) = k And ws.Cells(j, 7) = seltype And ws.Cells(i, 3) = seluser Then
            randst = randst + ws.Cells(j, 4).Value
            End If
        Next k
    Next j

    MonthlyDstAverage = randst / monthswithruns

End Select

End Function

Subscribe to Un mod diferit de a privi Economia by Email