............ Foro Excel
Si no lo has hecho aún: REGISTRATE!!!

Editar macro para busqueda o una nueva macro

Ver el tema anterior Ver el tema siguiente Ir abajo

Editar macro para busqueda o una nueva macro

Mensaje por JoaoM el Dom Ene 10, 2016 10:23 pm

Hola amigos
Baje una macro desde la WEB para adaptarla a lo que necesito pero no me funciona
Tengo un ejemplo (libro) en el cual tiene además del formulario para búsqueda, un otro para una barra de progreso.
En un form con 2 TextBox para colocar la fecha inicial y otro para fecha final, piso el botón Búsqueda y me presentará los resultados en el ListBox.

Se presenta el problema que esta macro congela EXCEL y además no sé como adaptarla porque es mui compleja y LAAAARGAA
Quisiera que el código sobre el form de la barra de progreso, estuviera separado del código del formulario UserForm4 y colocado o en su formulario (o modulo) para llamarlo con un Call dentro del código del UserForm4 de búsqueda y, no tenerlo mezclado en el código del botón de búsqueda.

Después de lo arriba conseguido vendrá nuevo tema que crearé después sobre; ¿como Imprimir los datos del ListBox, sin pasarlos a alguna hoja, TODOS no solo los visibles o seleccionados, TODO EL CONTENIDO DEL LISTBOX.
Dentro del código de impresión, meterle guardar como PDF y XLSX, macro que ya tengo
En el UserForm4 de búsqueda están 3 label que indica información en ROJO de lo que pretendo

Como ha sucedido otras veces me dice
EXCELGALI escribió:No es posible subir el archivo : has sobrepasado el tamaño total del espacio de almacenaje.(Espacio libre : 0 KB)


Dejo la macro a ver si si

Código:
Private Sub cmbBusque_Click()

'Controla los datos ingresados en los cuadro de textbox1 sean fechas
Application.ScreenUpdating = False

Sheets("Ventas").Select

'Controlo posibles errores
On Error Resume Next

If Not IsDate(TextBox1.Text) Then
MsgBox "fecha inválida"
TextBox1.SetFocus
Exit Sub
End If

'Valida fecha
Dim ubica1, ubica2 As String
Dim dia, mes As Integer
Dim año, fecha As Integer

'guardamos en variables el caracter encontrado en la posición 3 y 6
ubica1 = Mid(TextBox1.Text, 3, 1)

ubica2 = Mid(TextBox1.Text, 6, 1)

'comparamos si se trata de '/'
If ubica1 <> "/" Or ubica2 <> "/" Then

MsgBox ("Debes ingresar datos con este formato: dd/mm/aa")
TextBox1.SetFocus
Exit Sub
End If

dia = Mid(TextBox1.value, 1, 2)
mes = Mid(TextBox1.value, 4, 2)
año = Mid(TextBox1.value, 7, 4)
fecha = Len(TextBox1)
 
'Controla lo ingresado, si no se cumple no es fecha y sale en msgbox
If dia > 31 Or mes > 12 Or año < 1900 Or fecha > 10 Then
MsgBox "Fecha incorrecta"
TextBox1.SetFocus
Exit Sub
End If

'Controla los datos ingresados en los cuadro de textbox2 sean fechas
If Not IsDate(TextBox2.Text) Then
MsgBox "fecha inválida"
TextBox2.SetFocus
Exit Sub
End If

'Valida fecha
Dim ubicatext1, ubicatext2 As String
Dim dia1, mes1 As Integer
Dim año1, fecha1 As Integer

'guardamos en variables el caracter encontrado en la posición 3 y 6
ubicatext2 = Mid(TextBox2.Text, 3, 1)

ubicatext2 = Mid(TextBox2.Text, 6, 1)

'comparamos si se trata de '/'
If ubicatext2 <> "/" Or ubicatext2 <> "/" Then

MsgBox ("Debes ingresar datos con este formato: dd/mm/aa")
TextBox2.SetFocus
Exit Sub
End If

dia1 = Mid(TextBox2.value, 1, 2)
mes1 = Mid(TextBox2.value, 4, 2)
año1 = Mid(TextBox2.value, 7, 4)
fecha1 = Len(TextBox2)
 
'Controla lo ingresado, si no se cumple no es fecha y sale en msgbox
If dia1 > 31 Or mes1 > 12 Or año1 < 1900 Or fecha1 > 10 Then
MsgBox "Fecha incorrecta"
TextBox2.SetFocus
Exit Sub
End If

'Controla que la fecha final no sea menor a la inicial
Dim fechainicio As Date
Dim fechafinal As Date
fechainicio = TextBox1.value
fechafinal = TextBox2.value
If fechainicio > fechafinal Then
MsgBox "Fecha inválida"
TextBox2.SetFocus
Exit Sub
End If

'Muestra progressbar
Unload Me
ProgressForm.Show False

Dim R As Integer
Dim MT As Double
For R = 1 To 10
 MT = Timer
 ProgressForm.ProgressBar1.Max = 10
 Do
  Loop While Timer - MT < 0.05
   ProgressForm.ProgressBar1.value = R
   ProgressForm.Label1.Caption = "Consultando datos......."
  
 DoEvents
Next R
Unload ProgressForm

' Busca los datos entre las fechas ingresadas

'quito protección de hoja si es que la tiene
'Sheets("Vetas").Unprotect Password:="miclave"

'Dimensiono variables
Dim colinfo As Integer
Dim filainfo As Integer
Dim filavtas As Integer
Dim filavtas1 As Integer
Dim filanom As Integer
Dim filanom1 As Integer
Dim Acum, Tacum As Currency
Dim dato1 As Date
Dim dato2 As Date
Dim condi1  As Date
Dim condi2 As Date
Dim dato3 As String
Dim dato4 As String
Dim dato5 As String
Dim dato6 As String

colinfo = 2
filainfo = 3
filavtas = 2
filanom = 2
filanom1 = 2
filavtas1 = 2

cond1 = TextBox1.value
cond2 = TextBox2.value
Acum = 0
Tacum = 0
'Realiza bucle mientras no haya columnas vacias
 While Sheets("Resultado").Cells(2, colinfo) <> Empty
  
  'Realiza un nuevo bucle mietras no haya filas vacias recorriendo la fila de vtas
    While Sheets("Resultado").Cells(filainfo, 1) <> Empty
            
             While Sheets("vtas").Cells(filanom, 1) <> Empty
                    dato1 = Sheets("vtas").Cells(filavtas, 1).value
                    dato2 = Sheets("vtas").Cells(filavtas, 1).value
                    dato3 = Sheets("Resultado").Cells(2, colinfo).value
                    dato4 = Sheets("vtas").Cells(filanom, 6).value
                    dato5 = Sheets("Resultado").Cells(filainfo, 1).value
                    dato6 = Sheets("vtas").Cells(filavtas, 7).value
                
                    If dato1 >= cond1 And dato2 <= cond2 And dato3 = dato4 And dato5 = dato6 Then
                    
                            While Sheets("vtas").Cells(filavtas1, 1) <> Empty
                                   dato4 = Sheets("vtas").Cells(filanom1, 6).value
                                   dato5 = Sheets("Resultado").Cells(filainfo, 1).value
                                   dato6 = Sheets("vtas").Cells(filavtas1, 7).value
                                  
                                  If dato1 >= cond1 And dato2 <= cond2 And dato3 = dato4 And dato5 = dato6 Then
                                       Acum = Sheets("vtas").Cells(filavtas1, 9)
                                       Tacum = Tacum + Acum
                                       Sheets("Resultado").Cells(filainfo, colinfo) = Tacum
                                      
                                  End If
                                  
                               filavtas1 = filavtas1 + 1
                               filanom1 = filanom1 + 1
                             Wend
                            
                     End If
                Acum = 0
                Tacum = 0
                filavtas1 = 2
                filanom1 = 2
                filanom = filanom + 1
                filavtas = filavtas + 1
             Wend
      
      filavtas1 = 2
      filanom1 = 2
      filanom = 2
      filavtas = 2
      filainfo = filainfo + 1
      
      Wend
 filavtas1 = 2
 filanom1 = 2
 filanom = 2
 filavtas = 2
 filainfo = 3
 colinfo = colinfo + 1
 Wend
 
 'Cierro el formulario
 Unload Me
Sheets("Factura").Select
'Sheets("vtas").Protect Password:="miclave"

'Devuelvo movimientos a la pantalla
Application.ScreenUpdating = True
End Sub

Enlace al archivo

JoaoM

Masculino Cantidad de envíos : 38
Edad : 97
Ciudad - Pais : venez
Version de Excel : 2007-2010
Fecha de inscripción : 16/12/2011

Volver arriba Ir abajo

Re: Editar macro para busqueda o una nueva macro

Mensaje por JoaoM el Miér Feb 24, 2016 3:53 pm

Solucionado

JoaoM

Masculino Cantidad de envíos : 38
Edad : 97
Ciudad - Pais : venez
Version de Excel : 2007-2010
Fecha de inscripción : 16/12/2011

Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.