** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - Mucha demora en Recordset VBA Access
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoMucha demora en Recordset VBA Access
 Responder Responder
Autor
Mensaje
  Tema Buscar Tema Buscar  Opciones del Tema Opciones del Tema
JOchoa Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 02/Febrero/2019
Localización: Colombia
Estado: Sin conexión
Puntos: 39 		Enlace directo a este mensaje Tema: Mucha demora en Recordset VBA Access
    Enviado: 24/Octubre/2019 a las 05:45
Buenas tardes maestros del Access. 
Espero ser claro con mi inquietud porque pareciera que es muy general pero ya verán que es más bien puntual... y es la sgte:
Con VBA actualizo el valor de descuentos en los pagos de las personas. Esto debo correrlo varias veces al día y la rutina que tengo actualmente se esta demorando casi un minuto y solamente son unos 3000 registros. Hay un recordset anidado el cual fue hecho antes con dlookUp pero me di cuenta que demora lo mismo que con el recordset.
¿Por que se demora tanto esta consulta? ¿Qué estoy haciendo mal? ¿Cómo se podría optimizar este tiempo?
Muchas gracias maestros!!
------------------------------------------------------------------------------------------------------------
Sub ActualizaValorDescuento()
    Dim i As Long
    Dim rstPlanPagos As dao.Recordset, strSQL As String, CantRegistros As Long, PorcMora As Double, PenalidadMatricula As Currency
    Dim IdGrado As Integer, Inicio As Date, Fin As Date
    Dim stSQL As String
    Dim rs As dao.Recordset
    Dim rstDescuento As dao.Recordset
    Dim strSQLdescuento
    Dim SumaPension, SumaMatricula
    
    Inicio = Now()
    PorcMora = DLookup("ValorParametro", "tblParametros", "Parametro = 'InteresMoraPension'")
    Inicio = Now()
    strSQL = "SELECT * FROM qryPlanDePagos"
    Set rstPlanPagos = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
    rstPlanPagos.MoveLast
    CantRegistros = 0
    CantRegistros = rstPlanPagos.RecordCount
    If rstPlanPagos.RecordCount <> 0 Then
        With rstPlanPagos
            .MoveFirst
            Do Until .EOF
                '*********************************************************
                strSQLdescuento = "SELECT * FROM qryAlumnosDescuentos WHERE idAlumno = " & rstPlanPagos!idAlumno
                Set rstDescuento = CurrentDb.OpenRecordset(strSQLdescuento, dbOpenSnapshot)
                SumaPension = 0
                SumaMatricula = 0
                If rstDescuento.RecordCount <> 0 Then
                    With rstDescuento
                        .MoveFirst
                        CantRegistros = 0
                        CantRegistros = rstDescuento.RecordCount
                        SumaPension = 0
                        SumaMatricula = 0
                        Do Until rstDescuento.EOF
                            If rstDescuento![Aplica a] = 3 Then SumaPension = SumaPension + rstDescuento![% Desc]
                            If rstDescuento![Aplica a] = 1 Then SumaMatricula = SumaMatricula + rstDescuento![% Desc]
                            rstDescuento.MoveNext
                        Loop
                    End With
                End If
                .Edit
                If !idMovimientoSubconcepto = 3 Then !ValorDescuento = !ValorPagoNormal * SumaPension
                If !idMovimientoSubconcepto = 1 Then !ValorDescuento = !ValorPagoNormal * SumaMatricula
                .Update
                .MoveNext
              Loop
        End With
        rstDescuento.Close
        Set rstDescuento = Nothing
    End If
    rstDescuento.Close
    Set rstDescuento = Nothing
    DoCmd.Close acForm, "fmsgBarraProgreso"
    Fin = Now()
    Debug.Print "VALOR DESCUENTO:" & vbTab & vbNewLine & "" _
        ; "Inicio : " & vbTab & Inicio & Chr(10) & _
        "Fin : " & vbTab & vbTab & Fin & Chr(10) & _
        "Duracion : " & vbTab & Format((Fin - Inicio), "hh:mm:ss")
End Sub
Jochoa
Arriba
xavi Ver desplegable
Administrador
Administrador
Avatar
Terrassa-BCN

Unido: 10/Mayo/2005
Localización: Catalunya ||||
Estado: en línea
Puntos: 14738 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 09:39
Hola,

Primera idea.
Dejando de lado la cantidad de líneas "extras" (que no penalizan el rendimiento), abres cada vez un recordset rstDescuento.
Yo lo abriria antes del bucle pero agrupado por Alumno y [Aplica a]. Sumando [% Desc]
Nota: menudos nombrecitos de campos, perfectos para tener que escribir mucho más de la cuenta.

En cada registro del rstPlanPagos lanzaria un FindFirst para recuperar el registro.

Por mi experiencia penaliza mucho más abrir el recordset cada vez que lanzar una busqueda con el recordset abierto.

Haz la prueba y nos cuentas.

Un saludo
Xavi, un minyó de Terrassa

Mi web
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 15:04
Estas solicitando todos los campos de la tabla al colocar Select *.
Eso afecta el rendimiento.
Si creas el recordset como solo lectura y actualizas con una sql, la velocidad sera mejorada notablemente.
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 16:52
Hice un modelo aproximado de una consulta y una funcion que podria servirte, en caso de que dispongas de tiempo libre y curiosidad.

Declara en encabezado de modulo
dim idanterior as integer, subtotal as double

Sub query()
strsql = "update inmuebles Inm inner join edo_cuenta Edo on Inm.idinmueble = Edo.vinInmueble set Inm.domicilio = chooseAlicuota(Inm.idinmueble, inm.alicuota);"
CurrentDb.Execute strsql
End Sub

Function choosealicuota(id As Integer, alicuota As Double) As Double
if id <> idanterior then
   subtotal = 0
end if

    If alicuota < 1 Then
           subtotal = subtotal + alicuota * 10
    Else
           subtotal = subtotal + alicuota * 0.5
    End If
idanterior = id
    choosealicuota = subtotal
End Function

Donde qryPlanDePagos equivale a mi tabla de inmuebles (el objetivo es actualizar una columna de plan de pagos) y qryAlumnosDescuentosequivale a mi tabla de Edo_cuenta.
En la funcion podrias hacer el If para ir calculando el valor.
En esa funcion podrias comprobar si el id que llega es igual al anterior. De serlo, incrementas, de lo contrario, resetea a cero y suma.
Arriba
javier.mil Ver desplegable
Colaborador
Colaborador
Avatar

Unido: 10/Agosto/2005
Localización: España
Estado: Sin conexión
Puntos: 4830 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 16:59
Algunas ideas para ganar velocidad con los RecordSets lo encontraras AQUI:  http://www.accessdemo.info/docs_articulos/como-crear-recordset-mas-rapidos.html
https://www.accessdemo.info
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 18:58
La sub consulta esta compuesta de las dos tablas. MUY importante es que ordenes por la clave externa, de lo contrario, el resultado sera erroneo.

Actualizando 800 registros, no demora ni un segundo.

Sub query()
Dim inicio As Date, fin As Date
inicio = Now()
Set db = CurrentDb
strsql = "update (SELECT Inmuebles.IdInmueble, Inmuebles.Domicilio, Inmuebles.Alicuota FROM Inmuebles INNER JOIN Edo_Cuenta ON Inmuebles.IdInmueble = Edo_Cuenta.vinInmueble ORDER BY Edo_Cuenta.vinInmueble) set domicilio = chooseAlicuota(idinmueble, alicuota);"
db.Execute strsql
fin = Now()
dif = DateDiff("s", inicio, fin)
Call choosealicuota(0, 0, True)
Debug.Print "registros modificados:" & db.RecordsAffected & " registros en " & dif & " segundos."
End Sub

Function choosealicuota(idinm As Integer, alicuota As Double, Optional reset As Boolean) As Double
Static count As Integer
Static id As Integer

If reset = True Then 'esto es necesario para reiniciar las variables estaticas
    count = 0
    id = 0
    Exit Function
End If

If id <> idinm Then 'si el id del registro que viene es diferente al anterior, guardar el nuevo y colocar en cero el contador
    id = idinm
    count = 0
End If
   
count = count + 1

If alicuota < 1 Then
    choosealicuota = count
Else
    choosealicuota = count
End If
End Function
Arriba
JOchoa Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 02/Febrero/2019
Localización: Colombia
Estado: Sin conexión
Puntos: 39 		Enlace directo a este mensaje Enviado: 24/Octubre/2019 a las 23:28
Buenas tardes Maestros. Muchas gracias por su colaboración con este tema.
Maestro guarracuco :  He corregido lo del SELECT *. Ciertamente vi una reducción de 2 segundos con ello. Pero no sé entendí como hacer lo de actualizar con una SQL para este caso. Más tarde revisaré lo de la función que propone para ver como lo puedo implementar
Maestro XAVI: Como usted lo sugirió hice lo de sacar el recordset del bucle e implementé lo de agrupar y sumar (lo hice en una consulta externa qryAlumnosDescuentos1) para no tener que sumar con un nuevo bucle. También hice lo de encontrar los registros con rstPlanPagos.FindFirst "[% Desc] para no tener que recorrer todos los registros, pero allí me quedó la prueba porque me sale el error 3027 de que la consulta es de solo lectura.
El problema me sigue. Si pudieran revisarlo y darme una nueva luz se los agradezco mucho
___________________________________________

Sub ActualizaValorDescuento()
    Dim i As Long, lngCuenta As Long
    Dim rstPlanPagos As dao.Recordset, strSQL As String, CantRegistros As Long, PorcMora As Double, PenalidadMatricula As Currency
    Dim IdGrado As Integer, Inicio As Date, Fin As Date
    Dim stSQL As String
    Dim rs As dao.Recordset
    Dim rstDescuento As dao.Recordset
    Dim strSQLdescuento
    Dim SumaPension, SumaMatricula
    
    Inicio = Now()
    PorcMora = DLookup("ValorParametro", "tblParametros", "Parametro = 'InteresMoraPension'")
    strSQL = "SELECT idAlumno,idMovimientoSubconcepto,ValorDescuento,ValorPagoNormal, [% Desc] FROM qryPlanDePagos"
    Set rstPlanPagos = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
    rstPlanPagos.MoveLast
    CantRegistros = 0
    CantRegistros = rstPlanPagos.RecordCount
    lngCuenta = CantRegistros
    DoCmd.OpenForm "fmsgBarraProgreso", , , , acFormReadOnly
    i = 1
    If rstPlanPagos.RecordCount <> 0 Then
        With rstPlanPagos
            .MoveFirst
            Do Until .EOF
                rstPlanPagos.FindFirst "[% Desc] <> " & 0  '*****************************
                SumaPension = 0
                SumaMatricula = 0
                SumaPension = DLookup("[% Desc]", "qryAlumnosDescuentos1", "idalumno = " & rstPlanPagos!idAlumno & " AND [Aplica A] = 3 ") 'OJO aqui falta incluir Id año como condicional
                SumaMatricula = DLookup("[% Desc]", "qryAlumnosDescuentos1", "idalumno = " & rstPlanPagos!idAlumno & " AND [Aplica A] = 1 ")
                If SumaPension <> 0 Or SumaMatricula <> 0 Then
                    .Edit  '*****AQUI SALE EL ERROR 3027 NO SE PUEDE ACTUALIZAR....
                    If !idMovimientoSubconcepto = 1 Then !ValorDescuento = !ValorPagoNormal * SumaPension
                    If !idMovimientoSubconcepto = 3 Then !ValorDescuento = !ValorPagoNormal * SumaMatricula
                    .Update
                End If
                .MoveNext
                i = i + 1
                BarraProgreso Forms!frmPanelDeControl, ((i * 100) / lngCuenta), , "... Actualizando valores de descuento ..."
            Loop
        End With
    End If
    rstPlanPagos.Close
    Set rstPlanPagos = Nothing
    DoCmd.Close acForm, "fmsgBarraProgreso"
    Fin = Now()
    Debug.Print "VALOR DESCUENTO:" & vbTab & vbNewLine & "" _
        ; "Inicio : " & vbTab & Inicio & Chr(10) & _
        "Fin : " & vbTab & vbTab & Fin & Chr(10) & _
        "Duracion : " & vbTab & Format((Fin - Inicio), "hh:mm:ss")
End Sub
Jochoa
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 04:37
Prueba y comenta. Dudo mucho que funcione correctamente, ya que no puedo probar el codigo.

Sub ActualizaValorDescuento()
    Dim strSql As String, db As Database
    Set db = CurrentDb
    strSql = "update (SELECT PP.idAlumno, PP.idMovimientoSubconcepto,PP.ValorDescuento,PP.ValorPagoNormal, AD.[% Desc] FROM qryPlanDePagos PP " _
    & "INNER JOIN qryAlumnosDescuentos AD ON PP.idAlumno = AD.idAlumno ORDER BY AD.idAlumno) set " _
    & "PP.valorDescuento = f_Dscto(PP.idAlumno, AD.[Aplica a], PP.[% Desc], PP.ValorPagoNormal);"
    
    db.Execute strSql
    
    Call f_Dscto(0, 0, 0, 0, True)
End Sub

Function f_Dscto(idAlumno As Long, aplicaA As Integer, Desc As Double, ValorPagoNormal As Double, Optional reset As Boolean)
    Static idAnterior As Long
    Static SumaPension As Double
    Static SumaMatricula As Double
    Static ValorDescuento As Double
    
    If reset = True Then
        idAlumno = 0
        SumaPension = 0
        SumaMatricula = 0
        ValorDescuento = 0
        Exit Function
    End If
    
    If idAlumno <> idAnterior Then
        SumaPension = 0
        SumaMatricula = 0
        idAnterior = 0
        ValorDescuento = 0
    End If

    
    If aplicaA = 3 Then
        SumaPension = SumaPension + Desc
        ValorDescuento = ValorPagoNormal * SumaPension
    ElseIf aplicaA = 1 Then
        SumaMatricula = SumaMatricula + Desc
        ValorDescuento = ValorPagoNormal * SumaMatricula
    End If
    
    idAnterior = idAlumno
    
    f_Dscto = ValorDescuento
End Function
Arriba
JOchoa Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 02/Febrero/2019
Localización: Colombia
Estado: Sin conexión
Puntos: 39 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 17:04
Estimado Maestro Guarracuco, gracias por su ayuda con este tema. 
Le comento que he llevado al código a mi BD. Al principio tuve que cambiar en la linea de strSQL de 
AD.[% Desc] FROM a PP.[% Desc] FROM puesto que este campo pertenece es a ese alias de tabla (PP).
Tuve que hacer alguna modificación en la consulta qryPlanDePagos pues me salia que no era editable. Pero después de esto en la linea db.Execute strSql me saltó el error 3061 "Pocos parámetros. Se esperaba 1". Hice una prueba separando la strSQL en el SELECT y funciona bien (es decir, cree un recordset con el SELECT y lo seteó sin problema) por lo que creo que en esta parte no está el error. Hice otra prueba reemplazando la parte "PP.valorDescuento = f_Dscto(PP.idAlumno, AD.[Aplica a], PP.[% Desc], PP.ValorPagoNormal);" por "PP.valorDescuento = 100" (es decir, reemplacé la función por una constante) y SI QUE actualizó la tabla con el valor de 100 para el campo valorDescuento. He revisado los campos en la tabla-consulta qryAlumnosDescuentos y los campos estan creados y están bien. No se me ocurre qué otra cosa revisar. Por favor... si me pudiera seguir echando una manita.
Muchas gracias maestro.
Jochoa
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 17:39
revisa dentro de la función el nombre de los campos y/o los alias. Otra prueba puede ser colocando dentro de la función constantes, para que probar el funcionamiento de la misma.
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 17:42
El parametro [Aplica a] debe ser 1 o 3, de lo contrario se generará un error ya que los If no tiene un Else.
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 20:27
Ajusta los tipos de datos en la funcion, por los que tienes en tu base de datos.
Function f_Dscto( idAlumno As Long, aplicaA As Integer, Desc As Double, ValorPagoNormal As Double,......
Arriba
JOchoa Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 02/Febrero/2019
Localización: Colombia
Estado: Sin conexión
Puntos: 39 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 21:12
Estimado Maestro Guarracuco, nuevamente muchas gracias por su ayuda con este tema. 
El error se presentaba porque en el SELECT de la sentencia SQL no estaba el campo [Aplica a] que pedía en la función. Eso lo corregí y pude ejecutar la función (tenia razón usted: demora menos de 1 segundo!!). Sin embargo me encontré con varios issues:
1. El valor del descuento se estaba incrementando registro tras registro lo cual es un error. El valor del descuento solo se debe sumar dentro del mismo idAlumno. PAra solucionaer eso temporalmente hice esa suma en una consulta aparte (qryAlumnosDescuentos1) y comenté las lineas de la función donde se sumaba el descuento (como dije antes... esto es provisional para probar la totalidad de la función)
2. El valor de descuento es el que se encuentra en la tabla qryPlanDePagos1 y depende tanto del idAlumno como del campo Aplica A pero la función esta aplicando el mismo descuento para todos los registros de cada alumno (es decir, no discrimina pensión de matricula)
Creo que lo que falta es poco para funcione este código... 
Maestro nuevamente muchas gracias! (Abajo adjunto el código modificado)

_______________________________________________

Sub ActualizaValorDescuento()
    Dim strSql As String, db As Database
    Set db = CurrentDb
    strSql = "update (SELECT PP.idAlumno, PP.idMovimientoSubconcepto,PP.ValorDescuento,PP.ValorPagoNormal, PP.[% Desc], AD.[Aplica a] FROM qryPlanDePagos1 PP " _
    & "INNER JOIN qryAlumnosDescuentos AD ON PP.idAlumno = AD.idAlumno ORDER BY AD.idAlumno) set " _
    & "PP.valorDescuento = f_Dscto(PP.idAlumno, AD.[Aplica a], PP.[% Desc], PP.ValorPagoNormal);"
    db.Execute strSql
    Call f_Dscto(0, 0, 0, 0, True)
End Sub

Function f_Dscto(idAlumno As Long, AplicaA As Integer, Desc As Double, ValorPagoNormal As Double, Optional reset As Boolean)
    Static idanterior As Long
    Static SumaPension As Double
    Static SumaMatricula As Double
    Static ValorDescuento As Double
    Debug.Print idAlumno
    If reset = True Then
        idAlumno = 0
        SumaPension = 0
        SumaMatricula = 0
        ValorDescuento = 0
        Exit Function
    End If
    If idAlumno <> idanterior Then
        SumaPension = 0
        SumaMatricula = 0
        idanterior = 0
        ValorDescuento = 0
    End If
    If AplicaA = 3 Then
        'SumaPension = SumaPension + Desc
        ValorDescuento = ValorPagoNormal * Desc
    ElseIf AplicaA = 1 Then
        'SumaMatricula = SumaMatricula + Desc
        ValorDescuento = ValorPagoNormal * Desc
    End If
    idanterior = idAlumno
    f_Dscto = ValorDescuento
End Function
Jochoa
Arriba
guarracuco Ver desplegable
Moderador
Moderador


Unido: 24/Abril/2004
Localización: EEUU
Estado: Sin conexión
Puntos: 3239 		Enlace directo a este mensaje Enviado: 25/Octubre/2019 a las 22:24
Para corregir el problema 1, trata lo siguiente:
 en la funcion envia AD.idAlumno en lugar de PP.idAlumno

En cuanto al segundo, ignoro la logica a seguir.
Creo que debes modificar lo siguiente:

ValorDescuento = ValorDescuento + ValorPagoNormal * Desc

*Agregado*
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable