Código:
Function eXl_SubtotalHorizontal(Funcion As Integer, ParamArray Rangos() As Variant) As Variant
Application.Volatile
Dim R As Range, S As Double, P As Double, Vlr() As Double, C As Long, T As Long, V As Long, Rng As Variant
S = 0
P = 1
C = 0
T = 0
V = 0
On Error GoTo ManejoError
For Each Rng In Rangos
If TypeOf Rng Is Range Then
For Each R In Rng
If Not R.EntireColumn.Hidden Then
If Not IsEmpty(R.Value) Then
If IsNumeric(R.Value) Then
V = V + 1
S = S + R.Value
P = P * R.Value
ReDim Preserve Vlr(C)
Vlr(C) = R.Value
C = C + 1
End If
T = T + 1
End If
End If
Next R
Else
eXl_SubtotalHorizontal = CVErr(xlErrValue)
Exit Function
End If
Next Rng
Select Case Funcion
Case 1
If V > 0 Then
eXl_SubtotalHorizontal = WorksheetFunction.Average(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrDiv0)
End If
Case 2
eXl_SubtotalHorizontal = V
Case 3
eXl_SubtotalHorizontal = T
Case 4
If V > 0 Then
eXl_SubtotalHorizontal = WorksheetFunction.Max(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 5
If V > 0 Then
eXl_SubtotalHorizontal = WorksheetFunction.Min(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 6
If V > 0 Then
eXl_SubtotalHorizontal = P
Else
eXl_SubtotalHorizontal = 0
End If
Case 7
If V > 1 Then
eXl_SubtotalHorizontal = WorksheetFunction.StDev(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 8
If V > 0 Then
eXl_SubtotalHorizontal = WorksheetFunction.StDev_P(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 10
If V > 1 Then
eXl_SubtotalHorizontal = WorksheetFunction.Var(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 11
If V > 0 Then
eXl_SubtotalHorizontal = WorksheetFunction.Var_P(Vlr)
Else
eXl_SubtotalHorizontal = CVErr(xlErrNum)
End If
Case 9
eXl_SubtotalHorizontal = S
Case Else
eXl_SubtotalHorizontal = CVErr(xlErrValue)
End Select
Exit Function
ManejoError:
eXl_SubtotalHorizontal = CVErr(xlErrValue)
End Function
👉 Como hacer que la UDF (User Defined Functions) esté disponible como una Función Nativa de Excel
⭐ Si te gustó, por favor regístrate en nuestra Lista de correo y Suscríbete a mi canal de YouTube para que estés siempre enterado de lo nuevo que publicamos.
