Exporting Access Query data into MS word Table - vba

Question

I am trying to find a way to move the data from a query to a table in MS Word. I have attached a picture of the document
Here's the situation: When we close a case out, we need to create a document that includes several pieces of demographic data from that case and list of important dates to that case. The table needs to have some borders (underline on the date), and it needs to be inserted midway through the document (I am thinking bookmarks are the way to go). The document may be sent to other providers off of our network. (I am really hoping the pic attached...)
I have tried using Power Query (which does not allow the user to set parameters or prompt for criteria).
My initial thoughts are to create a recordset from the query and then create a loop to insert the data into the table. However, all the posts I could find seem to only deal with creating the table in word as the sole object. I also can't find how to point the recordset to a bookmark or particular table. The user will generate the document from Access (Right now, I have it where it will put certain dates, like open and close, into the corresponding Form Field in Word template, but I'm stuck at this juncture).
I have minor programming knowledge, just enough to be known as the local expert, when I am merely the only programming fish in the small pond. I would be happy to pointed in the right direction or given some code snippets (I would like to understand why/how they work).

Answer 1

With gratitude, I want to post the code for the solution. Of course, there is probably a better way to do it, but the solution works, and best of all I know why it works.
Public Function concatData() As String
Dim retVal As String
Dim rsHeader As Long, rsCounter As Long
Dim rs As DAO.Recordset
Dim Val As String
Dim strSQL As String
'This code puts the query into a recordset, which is then formatted into a table later
Val = [Forms]![FrmAllTracker]![CaseID]
strSQL = "Select * From QryTrackerInitRecRecv WHERE [CaseID] = " & Val
Set rs = CurrentDb.OpenRecordset(strSQL)
'Get headers
'For rsHeader = 0 To rs.Fields.Count - 1
' retVal = retVal & rs.Fields(rsHeader).Name & vbTab
'Next
'Replace last TAb with a carriage return
'retVal = Left(retVal, Len(retVal) - 1) & vbCr
Do While Not rs.EOF
'Get all records
For rsCounter = 0 To rs.Fields.Count - 1
retVal = retVal & rs.Fields(rsCounter).Value & vbTab
Next
retVal = Left(retVal, Len(retVal) - 1) & vbCr
rs.MoveNext
Loop
concatData = retVal
End Function
Private Sub BtnGenTracker_Click()
If IsNull(Me.CaseClosed) Then
MsgBox "Please Enter a Close Date", _
vbOKOnly + vbInformation
Exit Sub
End If
' Create pointers to Word Document
Dim wd As Word.Application
Dim doc As Word.Document 'doc As Word.Document
Dim bolOpenedWord As Boolean
Dim rng As Range
Dim Tbl As Word.Table
Dim MDate As String
MDate = Format([CaseOpen], "mm-dd-yyyy")
' Get pointer to Word Document
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If Err.Number = 429 Then
' If Word is not opened, open it
Set wd = CreateObject("Word.Application")
bolOpenedWord = True
End If
wd.Visible = True ' Set this to true if you want to see the document open
On Error GoTo 0
Set doc = wd.Documents.Add("\\gsmstore2\COE\Testing Database\TFT1.docx")
DoCmd.OpenForm FormName:="FrmRelRecSenAll"
With doc
On Error Resume Next
'sends particular fields to corresponding FormFields in Word
.FormFields("PtName").Result = [Forms]![FrmAllTracker]![FrmSubTherapyRef].[Form].[Text62]
.FormFields("COENum").Result = Me.COEMR
.FormFields("RefRec").Result = Me.CaseOpen
.FormFields("FirstCont").Result = Me.CaseOpen
.FormFields("InitRecsRecv").Result = DLookup("FirstOfRecordsRec", "QryTrackerInitRecRecvCFFirst")
.FormFields("SuffRecs").Result = Me.SuffRecDate
.FormFields("Init2").Result = Me.InitCaseDate
.FormFields("TeamRev").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 14")
.FormFields("MCRMeet").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 6")
.FormFields("MCRMeetAct").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 6")
.FormFields("FTDate").Result = InputBox("Please enter Date of FT Release", "FT Release", Default)
.FormFields("FirstAppt").Result = InputBox("Please enter Date of 1st offered appt", "1st Offered Date", Default)
.FormFields("AssessDebrief").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 15")
.FormFields("RptSent").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 11")
.FormFields("FFollow").Result = DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 12")
.FormFields("LFollow").Result = DLookup("ContactDate", "QryTrackerLFollow")
.FormFields("CaseClosed").Result = Me.CaseClosed
If Not IsNull(DLookup("ContactDate", "QryTrackerTeamRev", "[ContactType] = 4")) Then
.FormFields("Bill").Result = "Yes"
Else
.FormFields("Bill").Result = "No"
End If
.Application.Activate
Set rng = ActiveDocument.Bookmarks("Releases").Range
rng.Text = concatData()
Set Tbl = rng.ConvertToTable
End With
'This foramats the table
With Tbl
.Columns(1).Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Columns(1).Borders(wdBorderBottom).LineWidth = wdLineWidth050pt
.Columns(1).Borders.InsideLineStyle = wdLineStyleSingle
.Columns(1).Borders.InsideLineWidth = wdLineWidth050pt
.Columns(1).Width = 125
.Columns(2).Width = 450
.Columns(3).Delete
End With
wd.ActiveDocument.SaveAs2 ("\\Filelocation\COE\Case Files\" & COEMR & "\Tracking Sheet" & " " & MDate & ".docx")
Set doc = Nothing
Set wd = Nothing
Set rg = Nothing
Set Tbl = Nothing
End Sub