Option Explicit
Sub CopyFromWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim oBM As Object
Dim xlSheet As Worksheet
Dim NextRow As Long
Const strDocument as String = "D:\Path\Filename.docx"

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set xlSheet = ActiveSheet
    With xlSheet
        NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        Set wdDoc = wdApp.Documents.Open(Filename:=strDocument)
        For Each oBM In wdDoc.bookmarks
            Select Case LCase(oBM.Name)
                Case "site": .Range("A" & NextRow) = oBM.Range.Text
                Case "company": .Range("B" & NextRow) = oBM.Range.Text
                    'etc
            End Select
        Next oBM
    End With
    ActiveWorkbook.Save
lbl_Exit:
    Exit Sub
End Sub

Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlBook As Object
Dim wdDoc As Document
Dim oBM As Bookmark
Dim xlSheet As Object
Dim NextRow As Long
Const strWorkbookname As String = "C:\Path\WorkbookName.xlsx"

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.workbooks.Open(Filename:=strWorkbookname)
    Set xlSheet = xlBook.sheets(1)
    With xlSheet
        NextRow = .Cells(.Rows.Count, "A").End(-4162).Row + 1
        Set wdDoc = ActiveDocument
        For Each oBM In wdDoc.Bookmarks
            Select Case LCase(oBM.name)
                Case "site": .Range("A" & NextRow) = oBM.Range.Text
                Case "company": .Range("B" & NextRow) = oBM.Range.Text
                    'etc
            End Select
        Next oBM
    End With
    xlBook.Save
    xlBook.Close
lbl_Exit:
    Exit Sub
End Sub