Exportar tablas a nuevo libro segun criterios

[MauriciodeAbreu]

Buenas tardes amigos.

Actualmente tengo una macro que exporta las 4 tablas a un nuevo documento en un directorio x, dicha macro funciona a la perfeccion.

Pero..., necesito exportar estas 4 tablas a dicho libro de excel, pero dependiendo de ciertos criterios.

Los criterios son Seleccion por fecha, Rango de fechas, y Toda la tabla.

Me gustaria que la seleccion de criterios fuera a través de un formulario.

Es posible hacer esto ¿?

De antemano mi eterna gratitud por vuestra ayuda.

 

Exportar tablas.xlsx

[Antoni]

Cita

Actualmente tengo una macro que exporta las 4 tablas........

¿Y la macro?

 

 

 

 

'

[Haplox]

Hace 1 hora, Antoni dijo:

¿Y la macro?

Sí, eso iba a decir yo...

[Antoni]

Hace 1 hora, Haplox dijo:

Sí, eso iba a decir yo...

Parece que en Madrid os va bien con el bar, perdón, quise decir var. ??

¡ Felices fiestas amigo ! ?

[MauriciodeAbreu]

Buenos dias amigos.

Mil disculpas, en mi afan de hacer mas ligero el archivo de ejemplo para subirlo, pase por alto incluir las macros.

He aqui los archivos, uno es parte de mi proyecto, y el otro es el recipiente de las tablas.

Agradecido de antemano.

Saludos y espero tengan una feliz navidad.

PD. Disculpen mi poca habilidad con las macros, veran una serie de modulos con los cuales trate de solucionar algunos detalles al momento de exportar.

Exportar tablas.rar

[Haplox]

Hace 18 horas, Antoni dijo:

Parece que en Madrid os va bien con el bar, perdón, quise decir var. ??

¡ Felices fiestas amigo ! ?

Felices fiestas también para tí, aunque no debería felicitarte después de esa insinuación

Anda que vosotros estáis bien tambien...

?

[Haplox]

@MauriciodeAbreu , te dejo una solución con formulario. Están las macros para la fecha y el rango. EL de toda la tabla te lo dejo a ti, que es lo que ya tienes  ?

Prueba y comenta. De momento funciona teniendo ambos archivos en el mismo directorio, cambia las rutas según necesidad.

¡¡¡ Felices Fiestas !!! ⛄

 

Exportar tablas.xlsm

[Antoni]

Lo mismo que Haplox, pero con otra forma de verlo.

He partido de 2 consideraciones:

• Proceso Fecha, es un rango de fechas en el que la fecha final es igual a la inicial.
• Proceso Todo, es un rango de fechas en el que la fecha inicial es la mínima posible y la fecha final es máxima posible.

Conclusión, solo hay un tipo de proceso, Proceso Rango de fechas.

Exportar tablas.xlsm

[MauriciodeAbreu]

Buenas tardes estimados amigos, he tardado en responder ya que estaba realizando pruebas y adaptaciones al archivo de Haplox, y ahora al archivo de Antoni. Y la verdad que no soy capaz de lograrlo, cuando creo que ya lo he logrado, el codigo me la juega jajajaja.

En fin!!

Antes que nada daros las gracias a ustedes dos por vuestra valiosa ayuda, y a todos los que en su momento me han ayudado con mi proyecto o dudas, aunque el camino sera largo y duro, espero algun dia llegar al nivel de programacion que teneis vosotros.

Quiero decir que las dos propuestas son excelentes, pero tengo dos inquietudes.

1- Por desgracia o por fortuna, la tablas deben tener a juro una columna A vacia, ya que todo el codigo fue construido bajo ese formato.

Lo cual trate de solucionar en vuestros archivos, pero mis conocimientos y mi nivel de programacion son pauperrimos.

Cuando no inserto las columnas en ninguno de vuestors archivos exporta bien y mantiene los titulos de las columnas (titulos que puse en el archivo "Registro de ingresos y egresos"). Pero al insertar las columnas vacia (columnas A ue estan en el archivo original) Exporta toda la data, pero al colocarla, se mueve una columna a la derecha, y borra los titulos de las columnas.

Trate de solucionarlo, y lo unico que obtuve fue migraña

2- Lo otro, un detalli tal vez absurdo, seria saber como se le coloca bordes a la data que exporta, independientemente de si es por fecha, rango o completa.

Por lo demas, me quito el sombreo ante vosotros.

Si me podeis dar una mano en esto, se los agradeceria infinitamente.

Un abrazo desde Venezuela, y felices fiestas para todos.

PD. Me da la impresion que al exportar sobre lo ya exportado, no borra completamente  la totalidad de los datos anteriores dejando restos, voy a revisar bien y os comento.

[MauriciodeAbreu]

Creo que ya dome la bestia, estare informando

[MauriciodeAbreu]

Me rindo por hoy, no logro hacer que funcione, a veces borra los encabezados y a veces no

[Haplox]

Hace 13 horas, MauriciodeAbreu dijo:

Me rindo por hoy, no logro hacer que funcione, a veces borra los encabezados y a veces no

¿Y noes más sencillo eliminar esas columnas y ya está? Solo complican los cálculos... Te lo dejo resuelto, aunque no he probado demasiado...

Sigue faltando el exportartodaslas tablas. Prueba y comenta

Exportar tablas.xlsm

[MauriciodeAbreu]

Buenos dias estimados.

Agradecido por tu respuesta Haplox.

SI, seria mas sencillo, si no fuera porque tengo que modificar todo el proyecto, formulas, formulas matriciales, codigo..., y de verdad ya quiero terminar con el proyecto, de algo simple (una solicitud) he ido ampliando y modificando el proyecto para cada situacion que se me ha presentado, e ideas que he tenido para mejorarlo o adelantarme a posibles solicitudes y eventos, lo cual a sido positivo, puesto que al poco tiempo me las solicitan, y ya las tengo implementadas.

Lo bueno, es que he aprendido un monton con cada modificacion y/o consulta.

Pero al grano, la exportacion parcial o total ya la realizaba correctamente con las columnas A (eso lo modifique con exito), de hecho utilice tu propio codigo para hacer la exportacion completa, solo elimine dos lineas evidentes para dicho propósito.

If cel = f1 Then

End If

Mi problema, es que no mantiene los titulos de las columnas de la hoja destino, titulos que se los colocoque al archivo destino.

Tras la modificar el codigo, no los borra, pero al cabo de algunas pruebas con diferentes escenarios, me va borrando los titulos de las columnas de cada hoja con cada exportacion. SI los borrara todos al mismo tiempo lo entenderia, pero los borra progresivamente. Y para ser honesto no entiendo el porque, y mucho menos el como.

Mi otra duda era con respecto a los bordes, y ya lo implementaste, agradecido por ello...

Si me pudieas aclarar el porque borra progresivamente los titulos de las columnas, te lo agradeceria un monton, el no entenderlo me esta volviendo loco.

Agradecido como siempre por vuestar ayuda.

[MauriciodeAbreu]

Creo que ya lo solucione.

Opté por exportar la fila entera donde estan los titulos.

ftitulo = .Range("A4").EntireRow

.Range("A1").Resize(h, uC) = ftitulo

 

Sub Todo()
'Sub Todo
Dim wbdestino As Workbook, uFo&, uFd&, uC&, cel As Range
Dim datos(), i&, x&, h&

Application.ScreenUpdating = False

Set wbdestino = Workbooks.Open(ThisWorkbook.Path & "\Registros de Egreso e Ingresos.xlsm")
Set wborigen = ThisWorkbook

wborigen.Activate

m = MsgBox("¿Desea eliminar las Tablas ya Insertadas Anteriormente?", vbYesNo, "Importación de Tablas")

For i = 1 To Sheets.Count
    With Sheets(i)
        h = 1
        ftitulo = .Range("A4").EntireRow
        uFo = .Range("B" & Rows.Count).End(xlUp).Row
        uC = .Cells(4, 2).End(xlToRight).Column
        ReDim datos(1 To uFo, 1 To uC - 1)
        For Each cel In .Range(.Cells(5, uC - 1), .Cells(uFo, uC - 1))

                For x = 1 To uC - 1
                    datos(h, x) = .Cells(cel.Row, x + 1)
                Next x
                h = h + 1

        Next cel
    End With
    
    If h <= 1 Then
        h = 2
    End If
    
    If m = vbYes Then
        With wbdestino.Sheets(i)
            uFd = .Range("B" & Rows.Count).End(xlUp).Row
            .Activate
            .Range(.Cells(2, 2), .Cells(uFd, uC)).ClearContents
            .Range(.Cells(2, 2), .Cells(uFd, uC)).Borders.LineStyle = xlNone
            .Range("A1").Resize(h, uC) = ftitulo
            .Range("B2").Resize(h - 1, uC - 1) = datos
            .Range("B2").Resize(h - 1, uC - 1).EntireColumn.AutoFit
            .Range("B2").Resize(h - 1, uC - 1).Borders.LineStyle = xlContinuous
            wborigen.Activate
        End With
    Else
        With wbdestino.Sheets(i)
            .Activate
            uFd = .Range("B" & Rows.Count).End(xlUp).Row
            .Range(.Cells(2, 2), .Cells(uFd, uC)).Borders.LineStyle = xlNone
            .Range("B" & uFd + 1).Resize(h - 1, uC - 1) = datos
            .Range(Cells(2, 2), Cells(uFd + h - 1, uC)).Borders.LineStyle = xlContinuous
            .Range(Cells(2, 2), Cells(uFd, uC)).EntireColumn.AutoFit
            wborigen.Activate
        End With
    End If
Erase datos
Next i

wbdestino.Close savechanges:=True

End Sub

Hare algunas pruebas mas y comento.

Gracias!!

[MauriciodeAbreu]

Buenas noches amigos.

Disculpad la demora.

He realizado pruebas, y unas pequeñas modificaciones.

Deciros que, el exportado de las tablas hasta donde he podido revisar lo hace bien (realizando pruebas independientes con cada una de las opciones).

Pero..., cuando hago un nuevo exportado no borra la totalildad de lo exportado anteriormente.

Me explico mejor, si lo primero que exporto son todas las tablas, y despues exporto por fecha explicita, ejemplo 10/12/20, la macro borra y exporta (aparentemente bien), pero si bajamos lo suficiente en la hoja Salida del libro Destino, veremos que hay un pedazo de la tabla anterior (Tabla completa).

Yo ni idea de como corregir esto, si me pueden dar una mano, estare agradecido.

Por otro lado tengo dos dudas.

1- A pesar de tener Application.ScreenUpdating = False, realiza un parpadeo impreimpresionante durante el exportado, por mas que trate no pude corregirlo, sugerencias ¿?.

2- Como evitar la posibilidad de ingresar una fecha que no existe dentro de las tablas, es decir, si se ingresa una fecha que no existe deberia detenerse y avisar para corregir la fecha, como se podria realizar esta mejora ¿?

Agradecido por sus comentarios y ayuda.

PD. Dejo los cambios que se han hecho hasta el momento (agrege calendario), tal vez le sirva a alguien

Prueba 2.rar

[Haplox]

Hace 7 horas, MauriciodeAbreu dijo:

Me explico mejor, si lo primero que exporto son todas las tablas, y despues exporto por fecha explicita, ejemplo 10/12/20, la macro borra y exporta (aparentemente bien), pero si bajamos lo suficiente en la hoja Salida del libro Destino, veremos que hay un pedazo de la tabla anterior (Tabla completa).

A ver, esque ese fichero está lleno de trampas . En la imagen verás que hay celdas sin datos,por lo que al hayar la última fila, no corresponde con la real. Cambia el cálculo de uFd a una columna en la que estés SEGURO de que tendrán todas datos (me imagino que la columna con las fechas)

Hace 7 horas, MauriciodeAbreu dijo:

Como evitar la posibilidad de ingresar una fecha que no existe dentro de las tablas, es decir, si se ingresa una fecha que no existe deberia detenerse y avisar para corregir la fecha, como se podria realizar esta mejora ¿?

Esto solo te va a complicar y retardar la ejecución, puesto que tendrías que mirar en todas las hojas ¿No? Y más cuando cada hoja es diferente. Tendrías que volver a poner un contador u calcular últimas filas, columnas, etc. Pero tú mismo. Modifica el código a lo siguiente (solo está para una fecha concreta y da error si NO ESTA EN NINGUNA de las hojas
 

Private Sub CommandButton1_Click()
Dim f1 As Date, f2 As Date, uF&, c&, suma&, uC%, i%

If OptionButton1 = True Then
    f1 = TextBox1
    For i = 1 To Sheets.Count
        With Sheets(i)
            uC = .Cells(4, 2).End(xlToRight).Column
            uF = .Cells(5, uC - 1).End(xlDown).Row
            c = WorksheetFunction.CountIf(.Range(.Cells(5, uC - 1), .Cells(uF, uC - 1)), f1)
        End With
        suma = suma + c
    Next i
        If suma = 0 Then
            MsgBox "La fecha introducida no existe en las tablas", vbInformation, "Fecha no Encontrada"
            Exit Sub
        Else
            Call Fecha(f1)
        End If
ElseIf OptionButton2 = True Then
    f1 = TextBox2
    f2 = TextBox3
    Call Rango(f1, f2)
ElseIf OptionButton3 = True Then
    Call Todo
End If

End Sub

 

Hace 7 horas, MauriciodeAbreu dijo:

A pesar de tener Application.ScreenUpdating = False, realiza un parpadeo impreimpresionante durante el exportado, por mas que trate no pude corregirlo, sugerencias ¿?.

Comenta estas 2 líneas o elimínalas

If m = vbYes Then
        With wbdestino.Sheets(i)
            uFd = .Range("B" & Rows.Count).End(xlUp).Row
            '.Activate '<--- comentar o eliminar
            .Range(.Cells(2, 2), .Cells(uFd, uC)).ClearContents
            .Range(.Cells(2, 2), .Cells(uFd, uC)).Borders.LineStyle = xlNone
            .Range("A1").Resize(h, uC) = ftitulo
            .Range("B2").Resize(h - 1, uC - 1) = datos
            .Range("B2").Resize(h - 1, uC - 1).EntireColumn.AutoFit
            .Range("B2").Resize(h - 1, uC - 1).Borders.LineStyle = xlContinuous
            'wborigen.Activate '<--- comentar o eliminar
        End With

 

[MauriciodeAbreu]

Buenas amigos.

Gracias por responder Haplox.

En base al ejemplo actual, borrando todas las filas de la hoja (Shift + Fin  y Flecha abajo), y haciendo el exportado como lo indico arriba, deja parte de las tablas anteriores.

Yo la verdad no se casi sobre VBA (apenas tengo unos meses en esto), pero lo que creo entender es que al momento de borrar en la hoja Destino, borra en funcion del tamaño de lo que se exporta, o algo por el estilo, porque no llega a borrarlo todo.

Asi que me ahorre dolores de cabeza (en funcion de mis pocos conocimientos), y opté por cambiar estas lineas.

Las que definian el rango de borrado y bordes

            .Range(.Cells(2, 2), .Cells(uFd, uC)).ClearContents
            .Range(.Cells(2, 2), .Cells(uFd, uC)).Borders.LineStyle = xlNone

Por estas que borran todas las lineas y bordes

            .Range(.Cells(2, 2), .Cells(1048576, uC)).ClearContents
            .Range(.Cells(2, 2), .Cells(1048576, uC)).Borders.LineStyle = xlNone

Y santo remedio...

Con respecto al parpadeo, ya fue solucionado, muchas gracias.

Con respecto a la fecha inexistentes, voy a realizar pruebas, y si veo que tarda mucho, abadono la idea.

Gracias nuevamente, estare informando.

PD. Se me olvido comemtar que hay que dar doble clic sobre la fecha para que se inserte (archivo adjunto anterior)

[MauriciodeAbreu]

Hasta el momento funciona perfecto, no percibo lentitud en el proceso, supongo que con tablas de grandes dimensiones si se notara.

No hay fallas y el codigo esta adaptado a cualquier TextBox.

Muchas gracias Haplox y Antoni, marco como solucionado el tema.

Un abrazo...

[MauriciodeAbreu]

Buena tardes amigos.

Me tope con un detallazo, que no habia considerado ??‍♂️

Las hojas no estan en la misma posicion en mi proyeco, existe alguna manera de hacerlo con los nombres de las hojas dentro del bucle ¿?

Disculpad no haberlo considerado antes.

Agradecido de antemano por vuestro apoyo.

[MauriciodeAbreu]

Se me ocurrio hacerlo con una condicion IF (y funciona bien), de la siguiente forma, o hay una mejor forma ¿?

Sub Todo()
'Sub Todo
Dim wbdestino As Workbook, uFo&, uFd&, uC&, cel As Range
Dim Hoja As String
Dim datos(), i&, X&, h&

Application.ScreenUpdating = False

Set wbdestino = Workbooks.Open(ThisWorkbook.Path & "\Registros de Egreso e Ingresos.xlsm")
Set wborigen = ThisWorkbook

wborigen.Activate

m = MsgBox("Se eliminaran las tablas exportadas anteriormente. ¿Desea continuar?", vbYesNo, "Exportar de Tablas")

For i = 1 To 4 'Sheets.Count

If i = 1 Then Hoja = "Salidas"
If i = 2 Then Hoja = "Entradas"
If i = 3 Then Hoja = "N-Auditados"
If i = 4 Then Hoja = "Reemplazos"

    With Sheets(Hoja)
        h = 1
        ftitulo = .Range("A4").EntireRow
        uFo = .Range("B" & Rows.Count).End(xlUp).Row
        uC = .Cells(4, 2).End(xlToRight).Column
        ReDim datos(1 To uFo, 1 To uC - 1)
        For Each cel In .Range(.Cells(5, uC - 1), .Cells(uFo, uC - 1))
                For X = 1 To uC - 1
                    datos(h, X) = .Cells(cel.Row, X + 1)
                Next X
                h = h + 1
        Next cel
    End With
    
    If h <= 1 Then
        h = 2
    End If
    
    If m = vbYes Then
        With wbdestino.Sheets(i)
            uFd = .Range("B" & Rows.Count).End(xlUp).Row
            '.Activate
            '.Range(.Cells(2, 2), .Cells(uFd, uC)).ClearContents
            .Range(.Cells(2, 2), .Cells(1048576, uC)).ClearContents
            '.Range(.Cells(2, 2), .Cells(uFd, uC)).Borders.LineStyle = xlNone
            .Range(.Cells(2, 2), .Cells(1048576, uC)).Borders.LineStyle = xlNone
            .Range("A1").Resize(h, uC) = ftitulo
            .Range("B2").Resize(h - 1, uC - 1) = datos
            .Range("B2").Resize(h - 1, uC - 1).EntireColumn.AutoFit
            .Range("B1").Resize(h, uC - 1).Borders.LineStyle = xlContinuous
            'wborigen.Activate
        End With
    Else
        wbdestino.Close savechanges:=False
        Unload frmExportar
        MsgBox ("No se exporto ninguna Tablas")
        Application.ScreenUpdating = True
        Exit Sub
    End If
Erase datos

Next i

wbdestino.Close savechanges:=True
Unload frmExportar
MsgBox ("El exportado de las Tablas se ha realizado exitosamente")
Application.ScreenUpdating = True

End Sub

Gracias