VBA copy Access recordset to existing Word table

Dear Expert Exchange,

I am using Office 2003
I manage to generate a recordset from query to Excel worksheet and everything works fine, but instead of Excel Worksheet, I require to transfer the recordset to an existing Word document where it contain 2 tables, the recordset is suppose to go to table 2 where table 2 already formatted with Field Headings, the recordset should starts to fill starting from Row1, row data from recordset is dynamic.

Following is the vb code I use to post the recordset to Excel without problem.

Private Sub Command52_Click()
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Dim dbs As DAO.Database
    Set dbs = CurrentDb
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    ApXL.Visible = True
    Set xlWSh = xlWBk.Worksheets("Sheet1")
    If Len(strSheetName) > 0 Then
        xlWSh.Name = Left(strSheetName, 34)
    End If
    Set rst = dbs.OpenRecordset("Mytble", dbOpenDynaset)
    xlWSh.Range("B4").Select ' Header Posting
    For Each fld In rst.Fields
    ApXL.ActiveCell = fld.Name
    ApXL.ActiveCell.Offset(0, 1).Select
    xlWSh.Range("B4:H4").Font.Bold = True   ' Bold Header
    xlWSh.Range("B5").CopyFromRecordset rst ' Data Posting

    Set rst = Nothing

End Sub

Please show me how to post the same recordset to Word table line by line as I am new in vb programming.

Who is Participating?
IrogSintaConnect With a Mentor Commented:
Try this version:
   Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim wd As Object
    Dim fld As Field
    Dim iRow As Integer
    Dim iCol As Integer
    Dim iTbl As Integer

    Set wd = CreateObject("Word.Application")
    Set mydoc = wd.Documents.Open("C:\PathToFile\NameOfFile.docx")
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("Mytble")
    iTbl = 2    'Existing table number in Word document
    iRow = 2    'Starting row in table
    wd.Visible = True
    Do Until rs.EOF
        'add more rows if needed
        If iRow > mydoc.tables(iTbl).Rows.Count Then
        End If
        For Each fld In rs.Fields
            iCol = iCol + 1
            mydoc.tables(iTbl).Cell(iRow, iCol).Range.Text = Nz(fld.Value)
        iRow = iRow + 1
        iCol = 0
    Set rs = Nothing
    Set mydoc = Nothing
    Set wd = Nothing

Open in new window


pls try

Sub ExportToWord()

Dim db As DAO.Database
Dim rs As DAO.Recordset

Set db = CurrentDb()
Set rs = db.OpenRecordset("tblMyTable")
Set Wd = New Word.Application
Set myDoc = Wd.Documents.Open("c:\aa.doc")

Wd.Visible = True
i = 0
Do Until rs.EOF
    myDoc.Tables(1).Columns(1).Cells(i + 1).Range.Text = rs.Fields(0)
    myDoc.Tables(1).Columns(2).Cells(i + 1).Range.Text = rs.Fields(1)

i = i + 1

End Sub

Open in new window

kaysooAuthor Commented:
Hi Rgonzo1971,

Thank you very much for your reply.  It almost got it but no quite, the recordset did not copy into the table as intended.

I have attached two jpg files for clearer picture for explanation; on daily basis, data from AccessTable generate dynamic Rows of data, what I intended is to append the recordset from AccessTable to Word Table as shown Row by Row, Word Table already Pre-formatted with Row Heading, Word Table should insert new row to accommodate the recordset if require.

Thank you for your help.
kaysooAuthor Commented:
Tq vy much for your solution, fantastic !!!! It works like a charm !!!

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.