Sub ExcelDataToWord()
Dim objWord As Object, objDoc As Object
Dim strFolder As String, strName As String
Dim ws As Worksheet
Dim lngLastRow As Long
On Error GoTo Errorcatch
'------------browse---------------
'--------------------defaulting folder------------------------
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select a Folder"
  .AllowMultiSelect = False
  .ButtonName = "Select"
  .InitialView = msoFileDialogViewList
  .InitialFileName = "\\server\general\RAMS\RAM_RAMS"
  If Right(strName, 1) <> "\" Then
    strFolder = strFolder
  End If
  If .Show <> -1 Then
    Exit Sub
  Else
    strFolder = .SelectedItems(1)
  End If
 End With
'--------------------defaulting folder------------------------
'------------browse---------------

Set ws = ThisWorkbook.Sheets("RISKS")
lngLastRow = ws.Range("A65535").End(xlUp).Row
Set objWord = CreateObject("Word.Application")
ws.Range("A4" & ":H" & lngLastRow).Copy

'open the word doc
'objWord.Documents.Open "C:\Users\name\Desktop\RAMS AUTOMATION\Import table test.docx" 'change as required
With objWord
  .Visible = True
  Set objDoc = .Documents.Open(strFolder)
  'pastes the value of cell at the bookmark
  With objDoc.Bookmarks("RISKS").Range
    .Characters.Last.Next.PasteAppendTable
    .Tables(1).Rows(1).HeadingFormat = True
  End With
  .Activate
End With
Set objWord = Nothing: Set objDoc = Nothing
'Clear The Clipboard
Application.CutCopyMode = False
Exit Sub
Errorcatch:
Debug.Assert False
MsgBox Err.Description
' This is temporary, if you leave it in it will go into an endless loop so do not forget to remove
Resume
End Sub