Saltar al contenido

Registro lento de una un formulario a una Hoja de excel.

publicado

buen dia

el problema que tengo es el siguiente:

ocupó este código para registrar  información en una base de datos de excel, el problema que tengo es que  a la hora de hacer funcionar  el código por medio de un botón, tarda mucho en registrar porque la base de datos ya tiene 5,345 registros. quiero suponer que el problema está a la hora que busca la ultima fila vacía, hasta que la encuentra registra. 

Dim ifila As Long
Dim ws As Worksheet
Set ws = Sheets("BDPAGOS")
ifila = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ws.Cells(ifila, 1).Value = Me.NOFACTURA.Value
ws.Cells(ifila, 2).Value = VBA.CDate(Me.FECHAPAGO.Value)
ws.Cells(ifila, 3).Value = Me.BANCO.Value
ws.Cells(ifila, 4).Value = Me.CHEQUE.Value
ws.Cells(ifila, 5).Value = VBA.CDbl(Me.IMPORTEP.Value)
ws.Cells(ifila, 6).Value = Me.ESTATUS.Value

 

espero haber sido claro exponiendo mi problema y agradezco infinitamente a las personas que nos ayudan a resolverlos.

Gracias anticipadas.

 

Featured Replies

publicado
  • Autor
Hace 53 minutos , JSDJSD dijo:

Hola happy-christian, sube tu archivo aunque sea con datos ficticios

Hola JSDJSD  gracias por responder

arme un archivo nuevo con el código, pero ahí no me dio el problema, estoy subiendo todo el codigo que utilizo en el formulario.  el problema lo tengo en el código de guardar Lo identifique.

espero puedan ayudarme a que se pueda guardar mas rápido. 

Private Sub NOFACTURA_Change()
Worksheets("DATOS").Range("A3") = NOFACTURA.Value


FECHAFAC.Value = Worksheets("DATOS").Range("B3")
FECHASOLI.Value = Worksheets("DATOS").Range("C3")
FECHAVEN.Value = Worksheets("DATOS").Range("H3")
AVISO.Value = Worksheets("DATOS").Range("I3")
CONDICION.Value = Worksheets("DATOS").Range("G3")
IMPORTE.Value = Worksheets("DATOS").Range("F3").Text
PROVEEDOR.Value = Worksheets("DATOS").Range("D3")
MATERIAL.Value = Worksheets("DATOS").Range("E3")
MONEDA.Value = Worksheets("DATOS").Range("J3")
FECHAENVIO.Value = Worksheets("DATOS").Range("C6")

ESTATUSAC.Value = Worksheets("DATOS").Range("H6")


End Sub

'EL PROBLEMA TIENE QUE ESTAR POR AQUI DONDE SE GUARDA LA INFORMACION--------------------------------------------------------------'



Private Sub GUARDAR_Click()
Application.ScreenUpdating = False


Sheets("CONTROL").Select
If Range("A4:A" & Range("A" & Rows.Count).End(xlUp).Row).Find(NOFACTURA, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
  MsgBox "El numero de la factura ingresada no esta en la base de datos de control de pagos verifique", 64, ""
Exit Sub
End If

Sheets("BDPAGOS").Select
If Not Range("A4:A" & Range("A" & Rows.Count).End(xlUp).Row).Find(NOFACTURA, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
  MsgBox "El numero de la factura ingresada ya existe en esta lista, por favor verifique", 64, ""
Exit Sub
End If

Dim ifila As Long
Dim ws As Worksheet
Set ws = Sheets("BDPAGOS")
ifila = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

If Trim(Me.NOFACTURA.Value) = "" Then
Me.NOFACTURA.SetFocus
MsgBox "INGRESE EL NUMERO DE LA FACTURA"
Exit Sub
End If


If Trim(Me.FECHAPAGO.Value) = "" Then
Me.FECHAPAGO.SetFocus
MsgBox "INGRESA LA FECHA DE PAGO"
Exit Sub
End If

If Trim(Me.BANCO.Value) = "" Then
Me.BANCO.SetFocus
MsgBox "INGRESE EL BANCO DONDE SE PAGO LA FACTURA"
Exit Sub
End If


If Trim(Me.CHEQUE.Value) = "" Then
Me.CHEQUE.SetFocus
MsgBox "INGRESE LOS DIAS DE CONDICION DE PAGO"
Exit Sub
End If

If Trim(Me.IMPORTEP.Value) = "" Then
Me.IMPORTEP.SetFocus
MsgBox "SELECCIONE UN PROVEEDOR DE LA LISTA SI ESTE NO SE ENCUENTRA REGISTRELO CON EL BOTON REGISTRAR PROVEEDOR"
Exit Sub
End If

If Trim(Me.ESTATUS.Value) = "" Then
Me.ESTATUS.SetFocus
MsgBox "SELECCIONE EL ESTATUS DE LA FACTURA"
Exit Sub
End If


RPTA = MsgBox("¿DESEA REGISTRAR LA INFORMACION ?", vbYesNo + vbQuestion)
    If RPTA = vbNo Then Exit Sub
    

ws.Cells(ifila, 1).Value = Me.NOFACTURA.Value
ws.Cells(ifila, 2).Value = VBA.CDate(Me.FECHAPAGO.Value)
ws.Cells(ifila, 3).Value = Me.BANCO.Value
ws.Cells(ifila, 4).Value = Me.CHEQUE.Value
ws.Cells(ifila, 5).Value = VBA.CDbl(Me.IMPORTEP.Value)
ws.Cells(ifila, 6).Value = Me.ESTATUS.Value


Sheets("BDPAGOS").Select


Range("G4").Select
Selection.Copy
Range("G" & Cells.Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("G4").Select

Sheets("MENU").Select


NOFACTURA.Value = ""
FECHAPAGO.Value = ""
FECHASOLI.Value = ""
BANCO.Value = ""
CHEQUE.Value = ""
IMPORTEP.Value = ""
ESTATUS.Value = ""

NOFACTURA.SetFocus

End Sub



'EL PROBLEMA TIENE QUE ESTAR HASTA AQUI ------------------------------------------------------------------------------------------'

Private Sub Salir_Click()
Application.ScreenUpdating = False
   
NOFACTURA.Value = ""
FECHAPAGO.Value = ""
FECHASOLI.Value = ""
BANCO.Value = ""
CHEQUE.Value = ""
IMPORTEP.Value = ""
ESTATUS.Value = ""
    
    Unload Me
    
    Sheets("CONTROL").Select
    Range("A3:Q3").Select
    Selection.AutoFilter
    
    
    Sheets("MENU").Select
    
Worksheets("CONTROL").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="CONTROL01"
    Worksheets("BDFECHAENTRADA").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="CONTROL01"
     Worksheets("BDPAGOS").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="CONTROL01"
    Worksheets("DATOS").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="CONTROL01"
    Worksheets("FORMATO").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="CONTROL01"

End Sub

Private Sub UserForm_Initialize()

Application.ScreenUpdating = False

Worksheets("CONTROL").Unprotect Password:="CONTROL01"
    Worksheets("BDFECHAENTRADA").Unprotect Password:="CONTROL01"
    Worksheets("BDPAGOS").Unprotect Password:="CONTROL01"
    Worksheets("DATOS").Unprotect Password:="CONTROL01"
Worksheets("FORMATO").Unprotect Password:="CONTROL01"

Sheets("CONTROL").Select
Range("A3").Select

Do While ActiveCell <> Empty

    ActiveCell.Offset(1, 0).Select

    NOFACTURA.AddItem ActiveCell
Loop

Sheets("CONTROL").Select
    Range("A3:Q3").Select
    Selection.AutoFilter

Sheets("MENU").Select
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, ModoCerrar As Integer)
       If ModoCerrar <> 1 Then Cancel = 1
End Sub

Private Sub vercalendario_Click()


End Sub

Private Sub VCalendario_Click()
'Control de visualización del calendario
FechaActiva = ""
Set ControlActivo = FECHAPAGO
If IsDate(FECHAPAGO) = True Then FechaActiva = FECHAPAGO



Calendario.Show
End Sub



Private Sub UserForm_Terminate()

Unload Calendario

End Sub

 

saludos!

 

publicado
  • Autor
Hace 1 hora, JSDJSD dijo:

Sube el archivo que te da problemas

Hola JSDJSD

por el tamaño no me permite subir mi archivo pero puedes descargarlo de este link por favor.

https://1drv.ms/x/s!AhTpeRiQWgCGhitfIcOaSq93oWvy

este programa fue diseñado para controlar los pagos de los proveedores, y el problema lo estoy teniendo a la hora de registrar un pago.

Region%20Capture%201_zps9yavq81b.jpg

para registrar un pago tomamos una de las ultimas facturas porque las primeras ya tienen un pago registrado y te avisara del mismo y no te permitira registrar.

 

Region%20Capture%202_zpsrvyljc6y.jpg

 

ya que se llenen los textbox que estan en blanco le damos en registrar, ahí es donde tengo el problema porque tarda mucho en registrarme un pago

 

Region%20Capture%203_zpsj99daquh.jpg

 

toda la información se guarda en la siguiente hoja:

Region%20Capture%204_zpst6ra5cgy.jpg

Region%20Capture%205_zps1jpdj64n.jpg

 

espero y no tengas problemas para descargar mi archivo, te agradezco mucho tu ayuda

saludos!!

publicado
  • Autor
Hace 1 hora, JSDJSD dijo:

Sube el archivo que te da problemas

 

Hola JSDJSD  estoy subiendo el archivo en otros links 

por si no se puede abrir el primero

https://mega.nz/#!ApkFjYhL!VwSmV-6rqu3yEPZ1nfrssLznOsm50-MZxKW1WoUd1L8

https://1drv.ms/u/s!AhTpeRiQWgCGhjEIE77WokJufAPZ

 

saludos y gracias!

publicado
  • Autor
Hace 12 minutos , JSDJSD dijo:

Mañana te subo la solución

gracias!

publicado
  • Autor
Hace 9 horas, JSDJSD dijo:

Prueba el adjunto y comenta.

https://www.dropbox.com/s/iwvlmk5akymvftm/CONTROL DE PAGOS 2019 12 (Prueba 1).xlsm?dl=0

hola JSDJSD

revise tu archivo y veo que se cambio el formato de la tabla de la base de datos de los pagos, el problema al parecer se soluciono pero lo que veo que al hacer el cambio de esa tabla varias formulas que se concentraban en la Hoja de control se desajustaron y daban error, cambie las formulas y realice unas pruebas de registro de pago y me volvió a dar el problema de tardarse tanto en el registro.

estoy anexando tu archivo con la corrección de las formulas para que puedas ver lo que te comento.

https://1drv.ms/u/s!AhTpeRiQWgCGhjKlTuZgWevFESow

te agradezco mucho tu ayuda 

 

saludos!!

publicado
  • Autor
Hace 2 horas, JSDJSD dijo:

Que fallo es el que te da ?

Lo mismo a la hora de registrar un pago tarda demasiado.

 

publicado

A mi me funciona bien, luego te subo un vídeo para que lo veas

publicado
  • Autor
Hace 1 hora, JSDJSD dijo:

A mi me funciona bien, luego te subo un vídeo para que lo veas

Te funciono bien el archivo que te mandé ?

publicado
  • Autor
Hace 3 minutos , happy-christian dijo:

Te funciono bien el archivo que te mandé ?

O Como podría modificar mi macro para que a la hora de que busque la última celda vacía busque desde las ultimas Celdas llenas y no tenga que estar buscando desde la filial uno. 

 

Es es decir en vez de empezar por la filial uno que empiece a buscar desde fila 5340 y de ahí hacia abajo para buscar la fila vacía. Como podría modificar esta indicación en mi macro? 

Dim ifila As Long
Dim ws As Worksheet
Set ws = Sheets("BDPAGOS")
ifila = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ws.Cells(ifila, 1).Value = Me.NOFACTURA.Value
ws.Cells(ifila, 2).Value = VBA.CDate(Me.FECHAPAGO.Value)
ws.Cells(ifila, 3).Value = Me.BANCO.Value
ws.Cells(ifila, 4).Value = Me.CHEQUE.Value
ws.Cells(ifila, 5).Value = VBA.CDbl(Me.IMPORTEP.Value)
ws.Cells(ifila, 6).Value = Me.ESTATUS.Value
publicado 
ifila = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

 

 

Tu código busca desde el final de la hoja hacia arriba, hata encontrar la la primera fila con datos y con Offset(1,0), al encontrar la última fila en uso, salta 1 fila más la cual sería la última fila libre, cosa que está bién.

Con respecto a si me funciona el archivo que has subido sí.

 

 

Editado el por JSDJSD

publicado
  • Autor
Hace 2 horas, JSDJSD dijo:

Mira en el enlace como funciona perfectamente tu formulario con el último archivo que has subido.

 

https://www.dropbox.com/s/smkomwhd3yu3re6/2019-03-29_21-29-49.gif?dl=0

Una disculpa soy un **maravilloso** subi el mismo archivo que me enviaste, y tenia que subvierte el archivo donde solo corregi las formulas que se movieron por el cambio de la  tabla que hiciste.

este es el archivo correcto.

https://mega.nz/#!s8dwCADT!QJmYqabesTGctAwn7Mfi3WDW_-7Pscr5Q7vRoVdbKhs

https://1drv.ms/u/s!AhTpeRiQWgCGhjTfOiDbNX0eZHJL

espero no desesperarte, te agradezco mucho tu ayuda.

saludos!!

 

publicado
  • Autor
Hace 9 horas, JSDJSD dijo:

Que formulas son las que se desajusta ?

en la hoja de control 

HOJAS_zpsvy2muxlz.jpg

 

de la columna L HASTA P se tiene formulado para traer los datos que registramos del pago, esas son las formulas que se desajustaron cuando se cambio la tabla de pagos, al corregirlas nos vuelve a dar el error.

FORMULAS_zpsctsn2wv5.jpg

 

saludos y muchas gracias por tu ayuda.

 

CHRISTIAN ZAMORA.

 

publicado
  • Autor
En 30/3/2019 at 2:36 , JSDJSD dijo:

Que formulas son las que se desajusta ?

Te mande un mensaje con las formulas que se desajustaron.

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas