** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - VBA: Estadística. Función PercentRank para Access
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoVBA: Estadística. Función PercentRank para Access

 Responder Responder
Autor
Mensaje
genoma111 Ver desplegable
Administrador
Administrador
Avatar

Unido: 28/Marzo/2011
Localización: ...
Estado: Sin conexión
Puntos: 3248
Enlace directo a este mensaje Tema: VBA: Estadística. Función PercentRank para Access
    Enviado: 20/Agosto/2013 a las 02:17
Construí este sub para simular la función PercentRank de Excel.
Funciona ~70 veces más rápido que la de Excel.
Usualmente no es necesario este tipo de granularidad de los datos, sin embargo dejo la manera de emularla.
Más abajo dejo la manera de disminuir la granularidad y agrupar por rangos.

Llamada de la función:

Private Sub Command1_Click()
    PercentRank "ID", "signalValue", "tblValores"
End Sub

Función PercentRank:

'-------------------------------------------------------------------------------------------------------------
' Nombre:       PercentRank
' Propósito:    Emula la función PercentRank de Excel.
'               Crea una tabla con percentiles y posiciones
'               similar a la obtenida mediante la función PercentRank de Excel
'               pero de manera mucho más eficiente.
' Autor:        Diego F.Pereira-Perdomo
' Fecha:        Aug-19-2013
' Descripción:
'               CampoID : El campo ID.
'               strCampo : El campo con los valores sobre los que se calculan los percentiles y las posiciones
'               strTabla : La tabla en que están almacenados dichos valores.
'-------------------------------------------------------------------------------------------------------------
Public Sub PercentRank(CampoID As String, _
                      strCampo As String, _
                      strTabla As String)

    Dim dbs         As DAO.Database
    Dim dblVal      As Double
    Dim strSQLs     As String
    Dim strT        As String
    Dim rst         As DAO.Recordset
    Dim rstPR       As DAO.Recordset
    Dim lngRank     As Long
    Dim dblPercent  As Double
    Dim k           As Long
       
    Set dbs = CurrentDb
   
    strT = strTabla & "_PR"
   
    CreaTabla strT, 1
   
    strSQLs = "SELECT [" & CampoID & "], [" & strCampo & "] " & _
             " FROM [" & strTabla & "] " & _
             " ORDER BY [" & strCampo & "] DESC;"
   
    Set rst = dbs.OpenRecordset(strSQLs)
    Set rstPR = dbs.OpenRecordset(strT)
   
    With rst
   
        .MoveLast
        .MoveFirst
       
        If Not .EOF And Not .BOF Then
           
            Do Until .EOF
   
                If .Fields(1) = dblVal Then
                    lngRank = lngRank
                    k = k + 1
                Else
                    lngRank = lngRank + 1 + k
                    dblVal = .Fields(1)
                    k = 0
                End If
               
                dblPercent = 100 - .PercentPosition
                dblPercent = dblPercent / 100
               
                rstPR.AddNew
                rstPR.Fields(0) = .Fields(0)
                rstPR.Fields(1) = .Fields(1)
                rstPR.Fields(2) = lngRank
                rstPR.Fields(3) = dblPercent
                rstPR.Update
   
                .MoveNext
            Loop
           
        End If
       
        rstPR.Close
        .Close
       
    End With
   
    Set rstPR = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Sub

Función para creación de tabla:

Public Sub CreaTabla(strTabla As String, _
                         lngO As Long)
               
    Dim dbs     As DAO.Database
    Dim tdf     As DAO.TableDef
    Dim fldI    As DAO.Field
    Dim fldR    As DAO.Field
    Dim fldP    As DAO.Field
    Dim fldV    As DAO.Field
   
    Set dbs = CurrentDb
   
    Set tdf = dbs.CreateTableDef(strTabla)
   
    Select Case lngO
   
        Case 1
            Set fldI = tdf.CreateField("lngPoint", dbLong)
            Set fldV = tdf.CreateField("dblValue", dbDouble)
            Set fldR = tdf.CreateField("lngRank", dbLong)
            Set fldP = tdf.CreateField("dblPercent", dbDouble)
           
            tdf.Fields.Append fldI
            tdf.Fields.Append fldV
            tdf.Fields.Append fldR
            tdf.Fields.Append fldP
        Case 2
            Set fldV = tdf.CreateField("dblValue", dbDouble)
            Set fldP = tdf.CreateField("dblPercent", dbDouble)
           
            tdf.Fields.Append fldV
            tdf.Fields.Append fldP
    End Select
   
    dbs.TableDefs.Append tdf
    dbs.TableDefs.Refresh
   
    Application.RefreshDatabaseWindow
   
    Set fldI = Nothing
    Set fldR = Nothing
    Set fldP = Nothing
    Set fldV = Nothing
   
    Set tdf = Nothing
    Set dbs = Nothing
End Sub

******************************************************************
Agrupación por rangos:

Llamada de la función:

Private Sub Command2_Click()
    Percentiles "signalValue", "tblValores"
End Sub

Sub Percentiles:

'-------------------------------------------------------------------------------------------------------------
' Nombre:       Percentiles
' Propósito:    Interpola percentiles para los valores respectivos.
'               Crea una tabla con percentiles de manera eficiente.
' Autor:        Diego F.Pereira-Perdomo
' Fecha:        Aug-19-2013
' Descripción:
'               CampoID  : El campo ID.
'               strCampo : El campo con los valores sobre los que se calculan los percentiles
'               strTabla : La tabla en que están almacenados dichos valores.
'-------------------------------------------------------------------------------------------------------------
Public Sub Percentiles(strCampo As String, _
                       strTabla As String)
                      
    Dim dbs         As DAO.Database
    Dim dblVal      As Double
    Dim strSQLs     As String
    Dim strP        As String
    Dim rst         As DAO.Recordset
    Dim rstP        As DAO.Recordset
    Dim lngRank     As Long
    Dim dblPercent  As Double
    Dim k           As Long
       
    Set dbs = CurrentDb
   
    strP = strTabla & "_P"
   
    CreaTabla strP, 2
   
    strSQLs = "SELECT [" & strCampo & "] " & _
             " FROM [" & strTabla & "] " & _
             " ORDER BY [" & strCampo & "] DESC;"
   
    Set rst = dbs.OpenRecordset(strSQLs)
    Set rstP = dbs.OpenRecordset(strP)
   
    With rst
   
        .MoveLast
        .MoveFirst
       
        If Not .EOF And Not .BOF Then
            Do Until .EOF
               
                dblPercent = 100 - .PercentPosition
               
                rstP.AddNew
                rstP.Fields(0) = .Fields(0)
                rstP.Fields(1) = dblPercent
                rstP.Update
  
                .MoveNext
            Loop
        End If
       
        rstP.Close
        .Close
       
    End With
   
    Set rstP = Nothing
    Set rst = Nothing
    Set dbs = Nothing

    AgregaRangos strP

End Sub

Sub Agrega Rangos:

'-------------------------------------------------------------------------------------------------------------
' Nombre:       AgregaRangos
' Propósito:    Crea una consulta de datos agregados con rangos de valores por percentiles.
' Autor:        Diego F.Pereira-Perdomo
' Fecha:        Aug-19-2013
' Descripción:
'               strP  : La tabla sobre la que se crea la consulta.
'-------------------------------------------------------------------------------------------------------------
Public Sub AgregaRangos(strP As String)

    Dim dbs     As DAO.Database
    Dim strSQL  As String
    Dim qdf     As DAO.QueryDef
   
    Set dbs = CurrentDb

    strSQL = _
        " SELECT IIf(InStr(1,[dblPercent],'.'), " & _
        " CDbl(Left([dblPercent],InStr(1,[dblPercent],'.')+1)), " & _
        " CDbl([dblPercent])) AS Percentile, " & _
        " Max([dblValue]) AS MaxValue, Min([dblValue]) AS MinValue" & _
        " FROM [" & strP & "]" & _
        " GROUP BY IIf(InStr(1,[dblPercent],'.'), " & _
        " CDbl(Left([dblPercent],InStr(1,[dblPercent],'.')+1)), " & _
        " CDbl([dblPercent]))" & _
        " ORDER BY IIf(InStr(1,[dblPercent],'.'), " & _
        " CDbl(Left([dblPercent],InStr(1,[dblPercent],'.')+1)), " & _
        " CDbl([dblPercent])) DESC;"
   
    Set qdf = dbs.CreateQueryDef("qtRangos", strSQL)
  
    Application.RefreshDatabaseWindow

    Set qdf = Nothing
    Set dbs = Nothing
    MsgBox "listo"
End Sub



Editado por genoma111 - 20/Agosto/2013 a las 18:40
"To VBA or not to VBA... that's the question" DFP
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable