Macro para exportar tablas de excel a word de forma individual

Esta pregunta va en relación a otra que hice recientemente, el caso es que tengo un docmento de excel con un montón de tablas separadas or una línea en blanco y quisiera exportarlas a word de manera automática e individual, es decir, me gustaría que en word cada tabla fuese única para poder manejarlas como yo quiero.

El principal problema es que cuando las selecciono todas para copiarlas y las pego en word se me pega como si fuese una única tabla muy grande.

Espero que alguien me pueda ayudar, si necesitan más indicaciones tan solo pregúntenme.

1 respuesta

Respuesta
1

Prueba con la siguiente macro.

Tus tablas ya tienen que estar separadas por una fila.

La macro te crea un nuevo documento de word.

Sub ExportarTablas()
'Por.Dante Amor
    u = Range("A" & Rows.Count).End(xlUp).Row + 1
    Set appWord = CreateObject("word.application")
        appWord.Visible = True
        appWord.Documents.Add
    Range("A2").Select
    Do While Selection.Row < u
        celda = Selection.Address
        Selection.CurrentRegion.Select
        Selection.Copy
        appWord.Selection.TypeText "" & Chr(11)
        appWord.Selection.Paste
        Range(celda).Select
        Selection.End(xlDown).Select
    Loop
    Set appWord = Nothing
End Sub

Saludos.Dante Amor

Si es lo que necesitas.

Saludos y muchas gracias por tu pronta respuesta Dante, la macro funciona bastante bien, simplemente el problema que tiene es que a partir de la tabla número 1 las demás las copia dos veces y no logro identificar por que. ¿Alguna idea?

Puedes poner una imagen de cómo tienes los datos

Si, por supuesto aquí tienes la forma

Te cambio la macro

Sub ExportarTablas()
'Por.Dante Amor
    Set appWord = CreateObject("word.application")
        appWord.Visible = True
        appWord.Documents.Add
    u = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Cells(u + 1, "A") = "STEP"
    Cells(u + 1, "B") = "INPUT"
    ini = 1
    inicio = False
    For i = 1 To u + 1
        If UCase(Cells(i, "A")) = "STEP" And UCase(Cells(i, "B")) = "INPUT" Then
            If inicio Then
                Range(Cells(ini, "A"), Cells(i - 1, "E")).Copy
                appWord.Selection.TypeText "" & Chr(10)
                appWord.Selection.Paste
                inicio = False
                ini = i
                i = i - 1
            Else
                inicio = True
            End If
        End If
    Next
    Set appWord = Nothing
    Cells(u + 1, "A").Clear
    Cells(u + 1, "B").Clear
    MsgBox "Terminado"
End Sub

Recuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas