Función personalizada SUBTOTALES en Filas (Rango Horizontal)

Código

Function SubtotalesColumnas(Funcion As Integer, ParamArray Rangos() As Variant) As Variant

Application.Volatile

Dim C As Range, J As Double, O As Double, Vlr() As Double, R As Long, G As Long, E As Long, Rng As Variant

J = 0

O = 1

R = 0

G = 0

E = 0

On Error GoTo ManejoError

For Each Rng In Rangos

If TypeOf Rng Is Range Then

For Each C In Rng

If Not C.EntireColumn.Hidden Then

If Not IsEmpty(C.Value) Then

If IsNumeric(C.Value) Then

E = E + 1

J = J + C.Value

O = O * C.Value

ReDim Preserve Vlr(R)

Vlr(R) = C.Value

R = R + 1

End If

G = G + 1

End If

End If

Next C

Else

SubtotalesColumnas = CVErr(xlErrValue)

Exit Function

End If

Next Rng

Select Case Funcion

Case 1

If E > 0 Then

SubtotalesColumnas = WorksheetFunction.Average(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrDiv0)

End If

Case 2

SubtotalesColumnas = E

Case 3

SubtotalesColumnas = G

Case 4

If E > 0 Then

SubtotalesColumnas = WorksheetFunction.Max(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 5

If E > 0 Then

SubtotalesColumnas = WorksheetFunction.Min(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 6

If E > 0 Then

SubtotalesColumnas = O

Else

SubtotalesColumnas = 0

End If

Case 7

If E > 1 Then

SubtotalesColumnas = WorksheetFunction.StDev(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 8

If E > 0 Then

SubtotalesColumnas = WorksheetFunction.StDev_O(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 10

If E > 1 Then

SubtotalesColumnas = WorksheetFunction.Var(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 11

If E > 0 Then

SubtotalesColumnas = WorksheetFunction.Var_O(Vlr)

Else

SubtotalesColumnas = CVErr(xlErrNum)

End If

Case 9

SubtotalesColumnas = J

Case Else

SubtotalesColumnas = CVErr(xlErrValue)

End Select

Exit Function

ManejoError:

SubtotalesColumnas = CVErr(xlErrValue)

End Function