Auto creating tables in Word from an Excel document

Question

Hello all. I have a set of data in Excel which is like the below (in CSV format)

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

I want to be able to auto build a word document that presents this data, which the information grouped by heading1, into separate tables. So the word document would be like

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

Please could someone help me with this as it will save about 20 hours of very boring copy & pasting and formatting!

Thanks for any help

Answer 1

Dori,

Hope this is in time to help.

For this to work you need to set a reference to Word - in the VBA editor choose Tools>References and scroll down to Microsoft Word ##, where ## is 12.0 for Excel '07, 11.0 for Excel '03, etc. Also, the sheet shouldn't be filtered when you run this, and although you don't need to sort by heading 1, I assumed that you have.

The code assumes that your list starts with header in cell A1. IF that's not true you should make it so. It also assumes that your last column in D. You can adjust that in the line towards the end that starts with ".Copy".

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