Transfer word doc bookmarks to excel using macro

[Bedsy]

Hi all,

Could really use some help.

I have a word doc that has several bookmarks. I am trying..... Or to be honest, failing to write the vba to transfer the bookmarks to a specific excel spreadsheet named "register".

Am trying to have the vba find the next blank row in "register" spreadsheet and place the bookmarks in adjacent cells for example.

Bookmark "site" to go in column "a" in excel sheet
Bookmark "company" to go in column "b" in excel sheet and so forth.

Save/overwrite the spreadsheet and than close excel.



Thank guys.

[gmayor]

You can do it from Word or Excel:

Excel

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

Word

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

[Bedsy]

Thanks for the awesome code.

Everything seems to be working fine.

The excel sheet opens and requests to overwrite file when closing (amended code to SaveAs) but when i view the excel spreadsheet there is no data transfering over to it.

Unsure of the problem......Please help.

[gmayor]

Why 'SaveAs'? The macro should add to the data, provided your bookmark names are correctly represented in the code (in lower case). Saving will overwrite the original.
If you remove the Save line and leave the workbook open, is the data written to it?

[Bedsy]

Yes. Bookmark did start with capital. Code works a charm.