dimecres, 11 de febrer del 2015

Full Excel per comparar diferents tarifes que ofereixen les companyies telefòniques.

Aquest arxiu Excel ha estat realitzat amb un pur interès lúdic i, de ser possible, per estalviar-se algun euro en la factura del telèfon mòbil. Ja fa temps que el vaig acabar i no li he fet gaire cas, però pensava que potser algú en busqui un de semblant per Internet i el pugui aprofitar.

Les funcionalitats que estan previstes en aquest arxiu són les següents:
  •  Creació de tarifes diferents i anàlisi dels resultats mitjançant gràfiques.
  • Estudi de diferents escenaris d'ús dels serveis de telefonia mòbil i resultats econòmics segons cada tarifa.








L'arxiu Excel es pot descarregar aquí.


FULL "Paràmetres" Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) ''Disabling events Application.EnableEvents = False ''Disabling screen update Application.ScreenUpdating = False ''Unprotecting the current workbook ThisWorkbook.Unprotect Password:="password" ''Unprotecting the current worksheet Worksheets("Paràmetres").Unprotect Password:="password" ''If there's multi selection If Selection.Cells.Count > 1 Then ''A warning message is thrown MsgBox "No pots seleccionar més d'una cel·la alhora.", vbExclamation ''The last action is unded Application.Undo ''Going to exit label GoTo ExitLabel End If ''Declaring variables Dim rateCells, currentCell As Range Dim i As Integer ''Setting the range of rate name cells Set rateCells = Worksheets("Paràmetres").Range("C2:I2") ''Setting the color of selected range rateCells.Cells.Interior.Color = RGB(196, 215, 155) ''If the rate doesn't have any name, throws a warning message If (Target.Cells.Interior.ColorIndex = 2) And (Target.Value <> 0) Then MsgBox "Primer hauràs de posar-li nom a la tarifa.", vbExclamation ''Cleaning the contents of last cell updated Target.ClearContents ''Going to exit label GoTo ExitLabel End If '' If Not (Target.row = 2) Then ''If the cell contains a no numeric value or is not proper written If Not (IsNumeric(Target.Value)) Or (InStr(Target.Value, ".")) Then ''Checking the row of current cell to send proper warning message If (Target.row = 8) Or (Target.row = 11) Or (Target.row = 13) Then MsgBox "El valor numèric ha de ser un nombre Natural." & vbNewLine & "Exemple: 8.", vbExclamation Else MsgBox "El valor ha de ser un nombre Real positiu." & vbNewLine & "Exemple: 0,08.", vbExclamation End If ''Cleaning the contents of last cell updated Target.ClearContents End If End If ''Checking if the current value needs to be an integer If (Target.row = 8) Or (Target.row = 11) Or (Target.row = 13) Then ''If the numeric value is not an integer If Not ((Target.Value - Int(Target.Value)) = 0) Then ''A warning message is thrown and value is cleared MsgBox "El valor numèric ha de ser un nombre Natural." & vbNewLine & "Exemple: 8.", vbExclamation ''Cleaning the contents of last cell updated Target.ClearContents End If End If ''Showing cells to fill up For Each currentCell In rateCells ''Declaring and initializing temp variables Dim noBonoTrue As Boolean Dim bonoTrue As Boolean noBonoTrue = False bonoTrue = False ''Checking if there's data in bono area and no bono area at the same time For i = 1 To 16 ''If current cell is not empty If Not (IsEmpty(currentCell.Cells.Offset(i, 0))) Then ''Checking if current cell data refers to bono or no bono, and updating propoer boolean If ((1 <= i) And (i <= 4)) Then noBonoTrue = True ElseIf ((5 <= i) And (i <= 16)) Then bonoTrue = True End If End If Next i ''If both booleans are true If ((noBonoTrue = True) And (bonoTrue = True)) Then ''Throwing a warning message MsgBox "No es poden posar valors en la secció 'sense bono' i 'amb bono' alhora." & vbNewLine & _ "Hauràs d'esborrar totes les dades de la tarifa abans d'omplir l'altra secció.", vbExclamation ''Cleaning the contents of last cell updated Target.ClearContents ''Going to exit label GoTo ExitLabel End If ''Checking if there's any limit in the calls number If Not (IsEmpty(currentCell.Cells.Offset(6, 0))) And (IsEmpty(currentCell.Cells.Offset(13, 0))) Then ''Throwing a warning message MsgBox "Hi ha un límit de minuts fixat i no hi ha el preu del minut extra." & vbNewLine & _ "Això significa que no es podrà trucar un cop consumits els minuts" & vbNewLine & _ "del bono. Es posarà el valor '-1' per representar aquest cas." & vbNewLine & _ "Hauràs de tenir en compte la representació que això tindrà al gràfic.", vbExclamation ''Setting the cell value to -1 currentCell.Cells.Offset(13, 0).Value = -1 End If ''Checking if there's any limit in the SMS If Not (IsEmpty(currentCell.Cells.Offset(9, 0))) And (IsEmpty(currentCell.Cells.Offset(15, 0))) Then ''Throwing a warning message MsgBox "Hi ha un límit de SMS fixat i no hi ha el preu del SMS extra." & vbNewLine & _ "Això significa que no es podrà enviar cap SMS un cop exhaurits" & vbNewLine & _ "els SMS del bono. Es posarà el valor '-1' per representar aquest cas." & vbNewLine & _ "Hauràs de tenir en compte la representació que això tindrà al gràfic.", vbExclamation ''Setting the cell value to -1 currentCell.Cells.Offset(15, 0).Value = -1 End If ''Checking if there's any limit in the Internet connection If Not (IsEmpty(currentCell.Cells.Offset(11, 0))) And (IsEmpty(currentCell.Cells.Offset(16, 0))) Then ''Throwing a warning message MsgBox "Hi ha un límit de MB fixat i no hi ha el preu de la MB extra." & vbNewLine & _ "Això significa que no es podrà consumir cap MB un cop exhaurides" & vbNewLine & _ "les MB del bono. Es posarà el valor '-1' per representar aquest cas." & vbNewLine & _ "Hauràs de tenir en compte la representació que això tindrà al gràfic.", vbExclamation ''Setting the cell value to -1 currentCell.Cells.Offset(16, 0).Value = -1 End If ''If currentCellAddress is no empty If Not (IsEmpty(currentCell)) Then ''Iterating the offseted cells corresponding at no bonus case For i = 1 To 4 ''Setting proper color depending on the case, empty or not empty If Not (IsEmpty(currentCell.Cells.Offset(i, 0))) And Not (currentCell.Cells.Offset(i, 0) = 0) Then currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 17 Else currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 40 currentCell.Cells.Offset(i, 0).ClearContents End If Next i ''Iterating the offseted cells corresponding at bonus case For i = 5 To 16 ''Setting proper color depending on the case, empty or not empty If Not (IsEmpty(currentCell.Cells.Offset(i, 0))) And Not (currentCell.Cells.Offset(i, 0) = 0) Then currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 37 Else currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 36 currentCell.Cells.Offset(i, 0).ClearContents End If Next i ''Iterating the last 2 offseted cells For i = 17 To 18 ''Setting proper color depending on the case, empty or not empty If Not (IsEmpty(currentCell.Cells.Offset(i, 0))) And Not (currentCell.Cells.Offset(i, 0) = 0) Then currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 20 Else currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 19 currentCell.Cells.Offset(i, 0).ClearContents End If Next i ''Else, if currentCellAddress is empty Else ''Setting cells to white For i = 1 To 18 currentCell.Cells.Offset(i, 0).Interior.ColorIndex = 2 ''If the cell is not empty If Not (IsEmpty(currentCell.Cells.Offset(i, 0))) Then ''A warning message is thrown MsgBox "No pots enganxar cap valor perquè no has definit el nom de la tarifa.", vbExclamation ''The cell contents is cleared currentCell.Cells.Offset(i, 0).ClearContents End If Next i End If Next ''Calling 'chartMB' function to create a new chart Call chartMB ''Calling 'chartSMS' function to create a new chart Call chartSMS ''Calling 'chartPhoneCalls' function to create a new chart Call chartPhoneCalls ''Exit label ExitLabel: ''Protecting the current worksheet Worksheets("Paràmetres").Protect Password:="password" ''Protecting the current workbook ThisWorkbook.Protect Password:="password", Structure:=True ''Enabling events Application.EnableEvents = True ''Enabling screen update Application.ScreenUpdating = True End Sub FULL "Escenaris" Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) ''Disabling events Application.EnableEvents = False ''Disabling screen update Application.ScreenUpdating = False ''Unprotecting the current workbook ThisWorkbook.Unprotect Password:="password" ''Unprotecting the current worksheet Worksheets("Escenaris").Unprotect Password:="password" ''Calculate worksheet Calculate ''Protecting the current worksheet Worksheets("Escenaris").Protect Password:="password" ''Protecting the current workbook ThisWorkbook.Protect Password:="password", Structure:=True ''Enabling events Application.EnableEvents = True ''Enabling screen update Application.ScreenUpdating = True End Sub MÒDUL1 Option Explicit Function costTarifa(companyCell As Range, callsNumber As Integer, callsTotalMinuts As Integer, _ numSMS As Integer, numMB As Integer) ''declaring variables Dim callMinuteCostNoBono As Double Dim establishedCallCostNoBono As Double Dim SMSCostNoBono As Double Dim MBCostNoBono As Double Dim bonoCost As Double Dim callMinuteCostBono As Double Dim establishedCallCostBono As Double Dim SMSCostBono As Double Dim MBCostBono As Double Dim callExtraMinuteCostBono As Double Dim extraEstablishedCallCostBono As Double Dim extraSMSCostBono As Double Dim extraMBCostBono As Double Dim minimumConsumption As Double Dim ivaTax As Double Dim result As Double Dim totalInternetCost As Double Dim numMinutesBono As Integer Dim numSMSBono As Integer Dim numMBBono As Integer Dim callLimite As Boolean Dim SMSLimite As Boolean Dim MBLimite As Boolean ''Initializing variables callMinuteCostNoBono = companyCell.Offset(1, 0).Value establishedCallCostNoBono = companyCell.Offset(2, 0).Value SMSCostNoBono = companyCell.Offset(3, 0).Value MBCostNoBono = companyCell.Offset(4, 0).Value bonoCost = companyCell.Offset(5, 0).Value numMinutesBono = companyCell.Offset(6, 0).Value callMinuteCostBono = companyCell.Offset(7, 0).Value establishedCallCostBono = companyCell.Offset(8, 0).Value numSMSBono = companyCell.Offset(9, 0).Value SMSCostBono = companyCell.Offset(10, 0).Value numMBBono = companyCell.Offset(11, 0).Value MBCostBono = companyCell.Offset(12, 0).Value callExtraMinuteCostBono = companyCell.Offset(13, 0).Value extraEstablishedCallCostBono = companyCell.Offset(14, 0).Value extraSMSCostBono = companyCell.Offset(15, 0).Value extraMBCostBono = companyCell.Offset(16, 0).Value minimumConsumption = companyCell.Offset(17, 0).Value ivaTax = companyCell.Offset(18, 0).Value result = 0 totalInternetCost = 0 callLimite = False SMSLimite = False SMSLimite = False ''If there's a limit using services, changing the proper value ''and setting boolean to true If (callExtraMinuteCostBono < 0) Then callExtraMinuteCostBono = 0 callLimite = True ElseIf (extraSMSCostBono < 0) Then extraSMSCostBono = 0 SMSLimite = True ElseIf (extraMBCostBono < 0) Then extraMBCostBono = 0 MBLimite = True End If ''Calculating the cost of Internet connection result = reckonMBCost(MBCostNoBono, numMBBono, MBCostBono, extraMBCostBono, numMB) ''Adding the cost of SMS result = result + reckonSMSCost(SMSCostNoBono, numSMSBono, SMSCostBono, extraSMSCostBono, numSMS) ''Adding the cost of calls result = result + reckonCallingCost(callMinuteCostNoBono, establishedCallCostNoBono, numMinutesBono, _ callMinuteCostBono, establishedCallCostBono, _ callExtraMinuteCostBono, extraEstablishedCallCostBono, _ (callsTotalMinuts * callsNumber), callsNumber) ''Adding the cost of bonus result = result + (bonoCost * (1 + (ivaTax / 100))) ''Checking if result is higher than minimum consumption If (result < minimumConsumption) Then result = minimumConsumption * (1 + (ivaTax / 100)) End If ''If there's a limit using services, returning result with a warning message If (callLimite) Then costTarifa = result & " €" & vbNewLine & "Limitat." ElseIf (SMSLimite) And (numSMS > numSMSBono) Then costTarifa = result & " €" & vbNewLine & "Limitat." ElseIf (MBLimite) And (numMB > numMBBono) Then costTarifa = result & " €" & vbNewLine & "Limitat." ''If there's no limit, returning the result Else costTarifa = result End If End Function MÒDUL2 Option Explicit Function reckonSMSCost(SMSCostNoBono As Double, numSMSBono As Integer, _ SMSCostBono As Double, extraSMSCostBono As Double, numSMS As Integer) As Double ''Declaring and initializing variable Dim numSMSNoBono As Integer numSMSNoBono = 0 ''Calculating the SMS out of the bono If (numSMSBono > 0) Then numSMSNoBono = numSMSBono - numSMS End If ''Choosing the case between If (SMSCostNoBono > 0) Then ''If there's no bono reckonSMSCost = (numSMS * SMSCostNoBono) Else ''If there's bono If (numSMSNoBono >= 0) Then reckonSMSCost = (numSMS * SMSCostBono) Else reckonSMSCost = (numSMSBono * SMSCostBono) + ((-numSMSNoBono) * extraSMSCostBono) End If End If End Function Function reckonMBCost(MBCostNoBono, numMBBono, MBCostBono, extraMBCostBono, numMB) As Double ''Declaring and initializing variable Dim numMBNoBono As Integer numMBNoBono = 0 ''Calculating the MB out of the bono If (numMBBono > 0) Then numMBNoBono = numMBBono - numMB End If ''Choosing the case between If (MBCostNoBono > 0) Then ''If there's no bono reckonMBCost = (numMB * MBCostNoBono) Else ''If there's bono If (numMBNoBono >= 0) Then reckonMBCost = (numMB * MBCostBono) Else reckonMBCost = (numMBBono * MBCostBono) + ((-numMBNoBono) * extraMBCostBono) End If End If End Function Function reckonCallingCost(callMinuteCostNoBono, establishedCallCostNoBono, numMinutesBono, callMinuteCostBono, _ establishedCallCostBono, callExtraMinuteCostBono, extraEstablishedCallCostBono, _ totalCallNumMinutes, numCalls) As Double ''Declaring and initializing variables Dim numMinutesNoBono As Single numMinutesNoBono = 0 ''Calculating the minutes out of the bono If (numMinutesBono > 0) Then numMinutesNoBono = numMinutesBono - totalCallNumMinutes End If ''Choosing the case between If (callMinuteCostNoBono > 0) Then ''If there's no bono reckonCallingCost = (totalCallNumMinutes * callMinuteCostNoBono) + (establishedCallCostNoBono * numCalls) Else ''If there's bono If (numMinutesNoBono >= 0) Then reckonCallingCost = (totalCallNumMinutes * callMinuteCostBono) + (establishedCallCostBono * numCalls) Else reckonCallingCost = (numMinutesBono * callMinuteCostBono) + ((-numMinutesNoBono) * callExtraMinuteCostBono) _ + (numCalls * establishedCallCostBono) End If End If End Function MÒDUL3 Option Explicit Sub chartPhoneCalls() ''Declaring and initializating variables Dim PhoneCallsSerie As Series Dim PhoneCallsNumber(101) Dim totalPhoneCallsPrice(101) Dim phoneCallsDuration(101) Dim i As Single Dim j As Single Dim k As Single Dim PhoneCallMinutePrice As Double Dim PhoneCallConnectionPrice As Double Dim rateCells As Range Dim currentCell As Range Dim callMinuteCostNoBono As Double Dim establishedCallCostNoBono As Double Dim callMinuteCostBono As Double Dim establishedCallCostBono As Double Dim callExtraMinuteCostBono As Double Dim extraEstablishedCallCostBono As Double Dim ivaTax As Double Dim numMinutesBono As Integer Dim legendNumber As Integer legendNumber = 0 ''Setting range with rates description of 'Paràmetres' worksheet Set rateCells = Worksheets("Paràmetres").Range("C2:I2") ''Disabling alerts Application.DisplayAlerts = False ''Controlling a possible error On Error Resume Next Sheets("Anàlisi trucades telefòniques").Delete On Error GoTo 0 ''Adding a new chart and setting its parameters With Charts.Add .ChartType = xlXYScatterSmoothNoMarkers .Name = "Anàlisi trucades telefòniques" .HasTitle = True .ChartTitle.Text = "Anàlisi de consum en trucades telefòniques" & vbCrLf & _ "(de duració aleatòria entre 1 i 30 minuts cada trucada)" .ChartTitle.Characters(1, 42).Font.Size = 18 .ChartTitle.Characters(43, 100).Font.Size = 12 .Move after:=Worksheets(Worksheets.Count) .Axes(xlCategory, xlPrimary).HasTitle = True .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Número de trucades efectuades en un mes" .Axes(xlCategory, xlPrimary).AxisTitle.Font.Size = 14 .Axes(xlCategory).HasMajorGridlines = True .Axes(xlCategory).MaximumScale = 100 .Axes(xlValue, xlPrimary).HasTitle = True .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Cost en Euros (IVA inclòs)" & vbCrLf & _ "exceptuant el preu del bono" .Axes(xlValue, xlPrimary).AxisTitle.Characters(1, 26).Font.Size = 14 .Axes(xlValue, xlPrimary).AxisTitle.Characters(27, 100).Font.Size = 11 .Axes(xlValue).HasMajorGridlines = True .Axes(xlValue).MinimumScale = 0 ''Cleaning the chart With ActiveChart Do Until .SeriesCollection.Count = 0 .SeriesCollection(1).Delete Loop End With ''Iterating 101 times to get all prices range For j = 0 To 100 ''To calculate the duration of the calls, it's calculated the time call ''randomly between 1 minut par call (j+1) and 30 minuts par call (30*(j+1)) 'phoneCallsDuration(j) = Int(((10 * (j + 1)) - (j + 1) + (j + 1)) * Rnd + (j + 1)) phoneCallsDuration(j) = (Int(((30 - 1 + 1) * Rnd) + 1)) * (j) If (j > 50) Then phoneCallsDuration(j) = phoneCallsDuration(j) End If Next ''Iterating the 'rateCells' For Each currentCell In rateCells ''If the current item is not empty If Not IsEmpty(currentCell) Then ''Setting 'SMSSerie' to current Set PhoneCallsSerie = ActiveChart.SeriesCollection.NewSeries ''Initializing variables callMinuteCostNoBono = currentCell.Offset(1, 0).Value establishedCallCostNoBono = currentCell.Offset(2, 0).Value numMinutesBono = currentCell.Offset(6, 0).Value callMinuteCostBono = currentCell.Offset(7, 0).Value establishedCallCostBono = currentCell.Offset(8, 0).Value callExtraMinuteCostBono = currentCell.Offset(13, 0).Value extraEstablishedCallCostBono = currentCell.Offset(14, 0).Value ivaTax = currentCell.Offset(18, 0).Value ''Iterating 101 times to get all prices range For k = 0 To 100 ''Adding items to arrays with data PhoneCallsNumber(k) = k totalPhoneCallsPrice(k) = reckonCallingCost(callMinuteCostNoBono, establishedCallCostNoBono, _ numMinutesBono, callMinuteCostBono, establishedCallCostBono, _ callExtraMinuteCostBono, extraEstablishedCallCostBono, _ phoneCallsDuration(k), k) totalPhoneCallsPrice(k) = ((totalPhoneCallsPrice(k) * ivaTax) / 100) + totalPhoneCallsPrice(k) Next ''Printing out all data to the current serie with random color With PhoneCallsSerie .Name = currentCell.Value .Values = totalPhoneCallsPrice() .XValues = PhoneCallsNumber() .Border.Color = RGB(Int((255 - 1 + 1) * Rnd + 1), (255 - 1 + 1) * Abs(1 - Rnd) + 1, _ (255 - 1 + 1) * Abs(Rnd - 1) + 1) .Trendlines.Add Type:=xlPolynomial With PhoneCallsSerie.Trendlines(1) .Border.ColorIndex = 1 .Border.Weight = xlThin .Border.LineStyle = xlContinuous End With End With ''If there's no items in the legend If (legendNumber = 0) Then ''First legend text is added PhoneCallsSerie.Trendlines(1).Name = "Línies de tendència" Else ''Legend textes are set to proper ActiveChart.Legend.LegendEntries(legendNumber + 2).Delete PhoneCallsSerie.Trendlines(1).Name = "Línies de tendència" End If ''Updating counter legendNumber = legendNumber + 1 End If Next End With ''Selecting 'Paràmetres' worksheet Worksheets("Paràmetres").Select ''Enabling alerts Application.DisplayAlerts = True End Sub MÒDUL4 Option Explicit Sub chartSMS() ''Disabling alerts Application.DisplayAlerts = False ''Declaring variables Dim SMSSerie As Series Dim SMSNumber(101) Dim totalSMSPrice(101) Dim arrayRanges(7) Dim i As Integer Dim j As Integer Dim rateCells As Range Dim currentCell As Range Dim bonoCost As Double Dim SMSCostNoBono As Double Dim SMSCostBono As Double Dim extraSMSCostBono As Double Dim numSMSBono As Integer Dim ivaTax As Double '' Set rateCells = Worksheets("Paràmetres").Range("C2:I2") ''Controlling a possible error On Error Resume Next Sheets("Anàlisi SMS").Delete On Error GoTo 0 ''Adding a new chart and setting its parameters With Charts.Add .ChartType = xlXYScatterSmoothNoMarkers .Name = "Anàlisi SMS" .HasTitle = True .ChartTitle.Text = "Anàlisi de consum en SMS" .Move after:=Worksheets(Worksheets.Count) .Axes(xlCategory, xlPrimary).HasTitle = True .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Número de SMS enviats en un mes" .Axes(xlCategory, xlPrimary).AxisTitle.Font.Size = 14 .Axes(xlCategory).HasMajorGridlines = True .Axes(xlCategory).MaximumScale = 100 .Axes(xlValue, xlPrimary).HasTitle = True .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Cost en Euros (IVA inclòs)" & vbCrLf & _ "exceptuant el preu del bono" .Axes(xlValue, xlPrimary).AxisTitle.Characters(1, 26).Font.Size = 14 .Axes(xlValue, xlPrimary).AxisTitle.Characters(27, 100).Font.Size = 11 .Axes(xlValue).HasMajorGridlines = True .Axes(xlValue).MinimumScale = 0 ''Cleaning the chart With ActiveChart Do Until .SeriesCollection.Count = 0 .SeriesCollection(1).Delete Loop End With ''Iterating the 'rateCells' For Each currentCell In rateCells ''If the current item is not empty If Not IsEmpty(currentCell) Then ''Setting 'SMSSerie' to current Set SMSSerie = ActiveChart.SeriesCollection.NewSeries ''Initializing variables bonoCost = currentCell.Offset(5, 0).Value SMSCostNoBono = currentCell.Offset(3, 0).Value numSMSBono = currentCell.Offset(9, 0).Value SMSCostBono = currentCell.Offset(10, 0).Value extraSMSCostBono = currentCell.Offset(15, 0).Value ivaTax = currentCell.Offset(18, 0).Value ''Iterating 101 times to get all prices range For j = 0 To 100 ''Adding items to arrays with data SMSNumber(j) = j totalSMSPrice(j) = reckonSMSCost(SMSCostNoBono, numSMSBono, SMSCostBono, extraSMSCostBono, j) totalSMSPrice(j) = ((totalSMSPrice(j) * ivaTax) / 100) + totalSMSPrice(j) Next ''Printing out all data to the current serie with random color With SMSSerie .Name = currentCell.Value .Values = totalSMSPrice() .XValues = SMSNumber() .Border.Color = RGB(Int((255 - 1 + 1) * Rnd + 1), (255 - 1 + 1) * Abs(1 - Rnd) + 1, _ (255 - 1 + 1) * Abs(Rnd - 1) + 1) End With End If Next End With ''Selecting 'Paràmetres' worksheet Worksheets("Paràmetres").Select ''Enabling alerts Application.DisplayAlerts = True End Sub MÒDUL5 Option Explicit Sub chartMB() ''Disabling alerts Application.DisplayAlerts = False ''Declaring variables Dim MBSerie As Series Dim MBNumber(101) Dim totalMBPrice(101) Dim arrayRanges(7) Dim i As Integer Dim j As Integer Dim rateCells As Range Dim currentCell As Range Dim bonoCost As Double Dim MBCostNoBono As Double Dim MBCostBono As Double Dim extraMBCostBono As Double Dim numMBBono As Integer Dim ivaTax As Double ''Setting range with rates description of 'Paràmetres' worksheet Set rateCells = Worksheets("Paràmetres").Range("C2:I2") ''Controlling a possible error On Error Resume Next Sheets("Anàlisi Internet (MB)").Delete On Error GoTo 0 ''Adding a new chart and setting its parameters With Charts.Add .ChartType = xlXYScatterSmoothNoMarkers .Name = "Anàlisi Internet (MB)" .HasTitle = True .ChartTitle.Text = "Anàlisi de consum en MB" .Move after:=Worksheets(Worksheets.Count) .Axes(xlCategory, xlPrimary).HasTitle = True .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Número de MB consumits en un mes" .Axes(xlCategory, xlPrimary).AxisTitle.Font.Size = 14 .Axes(xlCategory).HasMajorGridlines = True .Axes(xlCategory).MaximumScale = 1000 .Axes(xlValue, xlPrimary).HasTitle = True .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Cost en Euros (IVA inclòs)" & vbCrLf & _ "exceptuant el preu del bono" .Axes(xlValue, xlPrimary).AxisTitle.Characters(1, 26).Font.Size = 14 .Axes(xlValue, xlPrimary).AxisTitle.Characters(27, 100).Font.Size = 11 .Axes(xlValue).HasMajorGridlines = True .Axes(xlValue).MinimumScale = 0 ''Cleaning the chart With ActiveChart Do Until .SeriesCollection.Count = 0 .SeriesCollection(1).Delete Loop End With ''Iterating the 'rateCells' For Each currentCell In rateCells ''If the current item is not empty If Not IsEmpty(currentCell) Then ''Setting 'SMSSerie' to current Set MBSerie = ActiveChart.SeriesCollection.NewSeries ''Initializing variables bonoCost = currentCell.Offset(5, 0).Value MBCostNoBono = currentCell.Offset(4, 0).Value numMBBono = currentCell.Offset(11, 0).Value MBCostBono = currentCell.Offset(12, 0).Value extraMBCostBono = currentCell.Offset(16, 0).Value ivaTax = currentCell.Offset(18, 0).Value ''Iterating 101 times to get all prices range For j = 0 To 100 ''Adding items to arrays with data MBNumber(j) = j * 10 totalMBPrice(j) = reckonMBCost(MBCostNoBono, numMBBono, MBCostBono, extraMBCostBono, j * 10) totalMBPrice(j) = ((totalMBPrice(j) * ivaTax) / 100) + totalMBPrice(j) Next ''Printing out all data to the current serie with random color With MBSerie .Name = currentCell.Value .Values = totalMBPrice() .XValues = MBNumber() .Border.Color = RGB(Int((255 - 1 + 1) * Rnd + 1), (255 - 1 + 1) * Abs(1 - Rnd) + 1, _ (255 - 1 + 1) * Abs(Rnd - 1) + 1) End With End If Next End With ''Selecting 'Paràmetres' worksheet Worksheets("Paràmetres").Select ''Enabling alerts Application.DisplayAlerts = True End Sub mòdul6 Option Explicit Sub updateTextBox() ''Declaring and initializating variables Dim currentCell As Range Dim rateCells As Range Dim currentCellAddress As Range Dim row As String Dim column As String Dim currentWrittenCell As String Dim i As Integer Dim j As Integer j = 0 ''Setting range with rates description of 'Escenaris' worksheet Set rateCells = Worksheets("Paràmetres").Range("C2:I2") ''Iterating the 'rateCells' range to find all existing rates For Each currentCell In rateCells ''Iterating all rows For i = 1 To 6 ''If current rate cell is empty If (IsEmpty(currentCell)) Then ''If the evaluated cell is not empty If Not (IsEmpty(Worksheets("Escenaris").Range(currentCell.Address).Offset(i, 1))) Then ''Emptying the cell Worksheets("Escenaris").Range(currentCell.Address).Offset(i, 1).ClearContents End If End If Next i Next ''First stage ''Updating values Worksheets("Escenaris").TextBox1.Text = Worksheets("Escenaris").Range("L13").Value Worksheets("Escenaris").TextBox2.Text = Worksheets("Escenaris").Range("M13").Value Worksheets("Escenaris").TextBox3.Text = Worksheets("Escenaris").Range("N13").Value Worksheets("Escenaris").TextBox4.Text = Worksheets("Escenaris").Range("O13").Value ''Second stage ''Updating values Worksheets("Escenaris").TextBox5.Text = Worksheets("Escenaris").Range("L14").Value Worksheets("Escenaris").TextBox6.Text = Worksheets("Escenaris").Range("M14").Value Worksheets("Escenaris").TextBox7.Text = Worksheets("Escenaris").Range("N14").Value Worksheets("Escenaris").TextBox8.Text = Worksheets("Escenaris").Range("O14").Value ''Reckoning new rates values ''Third stage ''Updating values Worksheets("Escenaris").TextBox9.Text = Worksheets("Escenaris").Range("L15").Value Worksheets("Escenaris").TextBox10.Text = Worksheets("Escenaris").Range("M15").Value Worksheets("Escenaris").TextBox11.Text = Worksheets("Escenaris").Range("N15").Value Worksheets("Escenaris").TextBox12.Text = Worksheets("Escenaris").Range("O15").Value ''Reckoning new rates values ''Fourth stage ''Updating values Worksheets("Escenaris").TextBox13.Text = Worksheets("Escenaris").Range("L16").Value Worksheets("Escenaris").TextBox14.Text = Worksheets("Escenaris").Range("M16").Value Worksheets("Escenaris").TextBox15.Text = Worksheets("Escenaris").Range("N16").Value Worksheets("Escenaris").TextBox16.Text = Worksheets("Escenaris").Range("O16").Value ''Reckoning new rates values ''Fifth stage ''Updating values Worksheets("Escenaris").TextBox17.Text = Worksheets("Escenaris").Range("L17").Value Worksheets("Escenaris").TextBox18.Text = Worksheets("Escenaris").Range("M17").Value Worksheets("Escenaris").TextBox19.Text = Worksheets("Escenaris").Range("N17").Value Worksheets("Escenaris").TextBox20.Text = Worksheets("Escenaris").Range("O17").Value ''Reckoning new rates values ''Sixth stage ''Updating values Worksheets("Escenaris").TextBox21.Text = Worksheets("Escenaris").Range("L18").Value Worksheets("Escenaris").TextBox22.Text = Worksheets("Escenaris").Range("M18").Value Worksheets("Escenaris").TextBox23.Text = Worksheets("Escenaris").Range("N18").Value Worksheets("Escenaris").TextBox24.Text = Worksheets("Escenaris").Range("O18").Value ''Reckoning new rates values ''Reckoning new rates values For Each currentCell In rateCells ''Iterating the 6 sceneries in column For i = 3 To 8 ''If current cell is not empty If Not (IsEmpty(currentCell)) Then ''Finding the cell's proper position column = ConvertToLetter(currentCell.column + 1) row = i currentWrittenCell = column & row ''Calling the function 'costTarifa' with the proper arguments Worksheets("Escenaris").Range(currentWrittenCell).Value = costTarifa(currentCell, _ Worksheets("Escenaris").Range("L1" & i).Value, _ Worksheets("Escenaris").Range("M1" & i).Value, _ Worksheets("Escenaris").Range("N1" & i).Value, _ Worksheets("Escenaris").Range("O1" & i).Value) End If Next i Next End Sub mòdul7 Option Explicit Function ConvertToLetter(iCol As Integer) As String ''Declaring and initializing variables Dim iAlpha As Integer Dim iRemainder As Integer iAlpha = Int(iCol / 27) iRemainder = iCol - (iAlpha * 26) ''Finding first char of column name If iAlpha > 0 Then ConvertToLetter = Chr(iAlpha + 64) End If ''Finding second char of column name If iRemainder > 0 Then ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64) End If End Function