automática la creación de tablas en Word a partir de un documento de Excel

Question

Tengo un conjunto de datos en Excel, que es como el siguiente (en formato CSV)

heading1, heading2, heading3, index 
A , randomdata1, randomdata2, 1 
A , randomdata1, randomdata2, 2 
A , randomdata1, randomdata2, 3 
B , randomdata1, randomdata2, 4 
C , randomdata1, randomdata2, 5 

Quiero ser capaz de auto construir un documento de Word que presenta esta información, que la información agrupada por encabezado1, se divide en tablas separadas. Por lo que el documento de la palabra sería como

Table A 
heading1, heading2, heading3, index 
A , randomdata1, randomdata2, 1 
A , randomdata1, randomdata2, 2 
A , randomdata1, randomdata2, 3 

Table B 
heading1, heading2, heading3, index 
B , randomdata1, randomdata2, 4 

Table C 
heading1, heading2, heading3, index 
C , randomdata1, randomdata2, 5 

Por favor alguien me puede ayudar con esto ya que le ahorrará cerca de 20 horas de copia muy aburrido & pegar y el formato!

Gracias por cualquier ayuda

Answer 1

Dori,

Hope esto es a tiempo para ayudar.

Para que esto funcione, debe establecer una referencia a Word - en el editor de VBA, seleccione Herramientas> Referencias y desplácese hacia abajo a Microsoft Word ##, donde ## es 12.0 para Excel '07, 11.0 para Excel '03, etc. Además, la hoja no se debe filtrar cuando se ejecuta esto, y aunque no es necesario ordenar por el encabezado 1, asumí que sí.

El código asume que su lista comienza con el encabezado en la celda A1. SI eso no es verdad deberías hacerlo así. También asume que su última columna en D. Puede ajustar eso en la línea hacia el final que comienza con ". Copiar".

Sub CopyExcelDataToWord() 

Dim wsSource As Excel.Worksheet 
Dim cell As Excel.Range 
Dim collUniqueHeadings As Collection 
Dim lngLastRow As Long 
Dim i As Long 
Dim appWord As Word.Application 
Dim docWordTarget As Word.Document 

Set wsSource = ThisWorkbook.Worksheets(1) 
With wsSource 
    lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    Set collUniqueHeadings = New Collection 
    For Each cell In .Range("A2:A" & lngLastRow) 
     On Error Resume Next 
     collUniqueHeadings.Add Item:=cell.Value, Key:=cell.Value 
     On Error GoTo 0 
    Next cell 
End With 
Set appWord = CreateObject("Word.Application") 
With appWord 
    .Visible = True 
    Set docWordTarget = .Documents.Add 
    .ActiveDocument.Select 
End With 
For i = 1 To collUniqueHeadings.Count 
    With wsSource 
     .Range("A1").AutoFilter Field:=1, Criteria1:=collUniqueHeadings(i) 
     .Range("A1:D" & lngLastRow).Copy 
    End With 
    With appWord.Selection 
     .PasteExcelTable linkedtoexcel:=False, wordformatting:=True, RTF:=False 
     .TypeParagraph 
    End With 
Next i 

For i = 1 To collUniqueHeadings.Count 
    collUniqueHeadings.Remove 1 
Next i 
Set docWordTarget = Nothing 
Set appWord = Nothing 

End Sub