Función personalizada SUBTOTALES en Filas (Rango Horizontal)

Código

Function SubtotalesColumnas(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

            SubtotalesColumnas = CVErr(xlErrValue)

            Exit Function

        End If

    Next Rng

    Select Case Funcion

        Case 1

            If V > 0 Then

                SubtotalesColumnas = WorksheetFunction.Average(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrDiv0)

            End If

        Case 2

            SubtotalesColumnas = V

        Case 3

            SubtotalesColumnas = T

        Case 4

            If V > 0 Then

                SubtotalesColumnas = WorksheetFunction.Max(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 5

            If V > 0 Then

                SubtotalesColumnas = WorksheetFunction.Min(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 6

            If V > 0 Then

                SubtotalesColumnas = P

            Else

                SubtotalesColumnas = 0

            End If

        Case 7

            If V > 1 Then

                SubtotalesColumnas = WorksheetFunction.StDev(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 8

            If V > 0 Then

                SubtotalesColumnas = WorksheetFunction.StDev_P(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 10

            If V > 1 Then

                SubtotalesColumnas = WorksheetFunction.Var(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 11

            If V > 0 Then

                SubtotalesColumnas = WorksheetFunction.Var_P(Vlr)

            Else

                SubtotalesColumnas = CVErr(xlErrNum)

            End If

        Case 9

            SubtotalesColumnas = S

        Case Else

            SubtotalesColumnas = CVErr(xlErrValue)

    End Select

    Exit Function

ManejoError:

    SubtotalesColumnas = CVErr(xlErrValue)

End Function