Private Sub but_Unsatisfactory_Click()
Dim QueryA As DAO.Recordset
Dim QueryB As DAO.Recordset
Dim dbs As DAO.Database
Dim strSQLA As String, strSQLB As String
Dim DA As String, DAX As String
Dim Variable As String
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim wdTbl As Word.Table
 
If Forms!frm_Assess!lst_Referrals.Column(5) <> "" Then
  Set dbs = CurrentDb
  DA = Forms!frm_Assess!txt_DA
  DAX = """" & DA & """"
 
  'Query SQL String for Checks
  strSQLA = "SELECT tbl_DA.DAID, tbl_DA.[DA No], tbl_DAConCheck.CheckTitle, tbl_DAConCheck.CheckOutcome, tbl_DAConCheck.CheckComments, tbl_DAConCheck.ConditionCategory, tbl_DAConCheck.Order " & _
    "FROM tbl_DA INNER JOIN tbl_DAConCheck ON tbl_DA.DAID = tbl_DAConCheck.DAID " & _
    "WHERE (((tbl_DA.[DA No])=" & DAX & ") AND ((tbl_DAConCheck.CheckOutcome)<> ""Invisible"")) " & _
    "ORDER BY tbl_DAConCheck.ConditionCategory, tbl_DAConCheck.Order;"
 
  'Query SQL String for RAI
  strSQLB = "SELECT tbl_DA.DAID, tbl_DA.[DA No], tbl_DAConCheck.RAIOutcome, tbl_DAConCheck.RAITitle, tbl_DAConCheck.RequestAdditionalInformation, tbl_DAConCheck.ConditionCategory, tbl_DAConCheck.Order " & _
    "FROM tbl_DA INNER JOIN tbl_DAConCheck ON tbl_DA.DAID = tbl_DAConCheck.DAID " & _
    "WHERE (((tbl_DA.[DA No]) = " & DAX & ") And ((tbl_DAConCheck.RAIOutcome) = True)) " & _
    "ORDER BY tbl_DAConCheck.ConditionCategory, tbl_DAConCheck.Order;"
 
  'Set Recordsets
  Set QueryA = dbs.OpenRecordset(strSQLA)
  Set QueryB = dbs.OpenRecordset(strSQLB)
 
 'Start Word
  Set wdApp = CreateObject("Word.Application")
  With wdApp
    .Visible = True
    .ScreenUpdating = False
 
    'Create a New Document
    Set wdDoc = .Documents.Add
    With wdDoc
 
      'Basic Document Format
      With .Styles(wdStyleNormal)
        .Font.Name = "Arial"
        .Font.Size = 11
        With .ParagraphFormat
          .LineSpacingRule = wdLineSpaceSingle
          .SpaceAfter = 0
          .SpaceBefore = 0
        End With
      End With
      'Title/IntroPage
      'Insert Gray Table
      Set wdTbl = .Tables.Add(Range:=.Range.Characters.Last, NumRows:=1, NumColumns:=1, _
        DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
      With wdTbl
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
        With .Cell(1, 1).Range
          .Shading.BackgroundPatternColor = -603937025
          .InsertAfter "Council Report Summary" & vbCr & _
            "The proposed development application does not comply with the requirements of Council's relevant policies."
          .Paragraphs.First.Range.Style = wdStyleStrong
        End With
      End With
      'Make space for query insertion
      .Range.InsertAfter vbCr & vbCr & vbCr & vbCr
      Set wdRng = .Paragraphs.Last.Previous.Previous.Range
      'Insert & format Query
      With wdRng
        .InsertBefore QueryA!ConditionCategory
        .Style = wdStyleStrong
        .Paragraphs.Alignment = wdAlignParagraphCenter
      End With
 
      'Checks Loop Start
      Variable = QueryA!ConditionCategory
      Do While Not QueryA.EOF
        'Check if Check Category is the same as previous if not type new category
        If Variable <> QueryA!ConditionCategory Then
          .Range.InsertAfter vbCr
          Set wdRng = .Paragraphs.Last.Previous.Range
          'Insert & format Query
          With wdRng
            .InsertBefore QueryA!ConditionCategory
            .Style = wdStyleStrong
            .Paragraphs.Alignment = wdAlignParagraphCenter
          End With
        End If
        'Make sure check has a title and insert table fill in with notes
        If IsNull(QueryA!CheckTitle) = False Then
          Set wdTbl = .Tables.Add(Range:=.Range.Characters.Last, NumRows:=1, NumColumns:=2, _
          DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
          With wdTbl
            .Style = "Table Grid"
            .ApplyStyleHeadingRows = True
            .ApplyStyleLastRow = False
            .ApplyStyleFirstColumn = True
            .ApplyStyleLastColumn = False
            .ApplyStyleRowBands = True
            .ApplyStyleColumnBands = False
            If IsNull(QueryA!CheckTitle) = False Then .Cell(1, 1).Range.Text = QueryA!CheckTitle
            If IsNull(QueryA!CheckOutcome) = False Then .Cell(1, 2).Range.Text = QueryA!CheckOutcome
            If IsNull(QueryA!CheckComments) = False Then .Cell(1, 2).Range.End.InsertBefore vbCr & QueryA!CheckComments
          End With
        End If
        Variable = QueryA!ConditionCategory
        QueryA.MoveNext
      Loop
      QueryA.Close
      'Save the document
      .SaveAs CurrentProject.Path & "\TestDoc.doc"
    End With
    .ScreenUpdating = True
  End With
Else
  MsgBox "Referal Completed Date Required", 0, "Date Required"
End If
Set wdRng = Nothing: Set wdTbl = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
End Sub