Sub ExcelDataToWord()
Dim objWord As Object
Dim ws As Worksheet
Dim lngLastRow As Long
On Error GoTo Errorcatch
lngLastRow = Sheets("RISKS").Range("A65535").End(xlUp).Row
Set ws = ThisWorkbook.Sheets("RISKS")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
ws.Range("A4" & ":H" & lngLastRow).Copy
'------------browse---------------
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'--------------------defaulting folder------------------------
With fileExplorer
  .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---------------
'open the word doc
'objWord.Documents.Open "C:\Users\name\Desktop\RAMS AUTOMATION\Import table test.docx" 'change as required
objWord.Documents.Open FileName:=strFolder  'pastes the value of cell at the bookmark
With objWord.ActiveDocument.Bookmarks("RISKS").Range.Characters.Last.Next.PasteAppendTable
  HeadingFormat = True
End With
'Optimize Code
Set objWord = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
'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