Using the following code, I can pull multiple records into a table in word from Access. But I can find no way of formatting a column that was currency, back to currency after pulling the data in.
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim i As Integer
Dim intRecords As Integer
Dim intColumns As Integer
strSQL = "QTopLevelPage2a"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.EOF = TrueThen
MsgBox"No records were retrieved. Cannot continue.", vbCritical,"Request Aborted"
rs.Close
Set db =Nothing
Exit Sub
End If
'lets get some counts
rs.MoveLast
intRecords = 0
intRecords = rs.RecordCount
Debug.Print "rs.RecordCount = " & intRecords
'Name the Range for the data added
intRecords = intRecords '+ 1 'add one row for the headernames
'lets see how many columns we have
intColumns = 0
intColumns = rs.Fields.Count
'*************************************
Dim myWordApp As Word.Application
Dim docNew As Word.Document
Dim docTable As Word.Table
Set myWordApp = CreateObject("Word.Application")
myWordApp.Visible = True
Set docNew = myWordApp.Documents.Open("C:\Test\WordDocFolder\Te stMailMerge.doc")
'Create a table that has the correct number of cells
docNew.Tables.Add Range:=docNew.Range(Start:=0, End:=0),NumRows:=intRecords, NumColumns:=intColumns
Set docTable = docNew.Tables(1)
'Get some header names in the first Row
For i = 1 Tors.Fields.Count
docTable.Cell(1, i).Range.text = rs.Fields(i - 1) '.Name
Next i
rs.MoveLast
While rs.BOF = False
'Populate the last row
For i = 1 Tors.Fields.Count
If NotIsNull(rs.Fields(i - 1).Value) Then
docTable.Cell(intRecords, i).Range.text =rs.Fields(i - 1) '.Value
End If
Next i
Debug.Print intRecords
intRecords = intRecords - 1
rs.MovePrevious
Wend
' Start with the second column.
docTable.Columns(2).Select
'Extend acrossthe specified count of columns.
myWordApp.Selection.MoveRight Unit:=wdCharacter, _
Count:=1,Extend:=wdExtend
myWordApp.Selection.NumberFormat = "$#.##00.00"
'docNew.Activate
'docNew.PrintPreview
docNew.Save
docNew.Close
myWordApp.Quit
Set docNew = Nothing
Set myWordApp = Nothing
End Sub