Copy tables from documents to another documents with predefined bookmarks

[Pearce]

Hello all,


I am looking for some assistance in a matter, not sure if best to do it in Excel or Word VBA; so I'll start with Word VBA.

I have an application that generates Word documents – each generated Word document contains named tables (TableA, TableB, ...). I’d like to copy all tables from these generated Word documents to existing documents IN predefined bookmark locations (named BookmarkA, BookmarkB, ...), i.e. TableA in BookmarkA, TableB in BookamrkB, etc.

For each generated Word document there is one existing Word document. So I’d like to copy all tables from the generated document X to the existing document X, all tables from the generated document Y to the existing document Y, all tables from the generated document Z to the existing document Z, etc…

Number of generated Word documents contain 4 tables (either TableA, TableB, TableC, TableE or TableA, TableB, TableD, TableE) and their corresponding existing documents contain 4 bookmarks (either BookmarkA, BookmarkB, BookmarkC, BookmarkE or BookmarkA, BookmarkB, BookmarkD, BookmarkE).
Most of generated Word documents contain 5 tables (TableA, TableB, TableC, TableD, TableE) and their corresponding target documents contain 5 bookmarks (BookmarkA, BookmarkB, BookmarkC, BookmarkD, BookmarkE).

Now as this is going to be somewhat repetitive task the content of the bookmarks in the existing documents need to be cleared first before copying the tables from the generated documents.
The generated (table source) documents are located in a different folder than the existing (target) documents. The corresponding source and target documents can be matched by the first 6 characters of a filename. I was wondering whether a list of matching source documents (column A) and target documents (column B) in an Excel would make thing easier.


I am new to VBA. I have searched for a similar problem to get me started but haven’t found any.
Any help or advice would be much appreciated.


Pearce

[Pearce]

I have tried to put together a code that would delete the contents of bookmarks using info from several VBA forums. It seems that being a new memeber the forum won't let me to post links to the sources in my message.

So far the code works only with a plain text - it deletes the text inside the bookmarks.

Next I will try to modify the code so that it would delete bookmarked tables using info from: rlbcontractor.com/vba-deleting-a-bookmarked-table-without-deleting-the-bookmark


Code:

Option Explicit

Sub ClearContentsOfBookmarks()
Application.ScreenUpdating = False

Dim strFolder As String
Dim strFile As String
Dim strName As String
Dim wdDoc As Document
Dim i As Long

strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)

While strFile <> ""
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    wdDoc.Activate
    With wdDoc
        For i = 1 To ActiveDocument.Bookmarks.Count
            strName = ActiveDocument.Bookmarks(i).Name
            FillBM strName, ""
        Next i
    End With
    wdDoc.Close SaveChanges:=True
    strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = False
End Sub

Private Sub FillBM(strBMName As String, strValue As String)
'Graham Mayor
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        oRng.Text = strValue
        oRng.Bookmarks.Add strBMName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[gmayor]

The following should help

Sub Macro1()Dim oRng As Range
    Set oRng = ActiveDocument.Tables(1).Range
    FillBM_with_Table "BM1", oRng
    Set oRng = Nothing
End Sub


Private Sub FillBM_with_Table(strbmName As String, oSource As Range)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strbmName).Range
        If oRng.Tables.Count > 0 Then oRng.Tables(1).Delete
        oRng.FormattedText = oSource.FormattedText
        oRng.Bookmarks.Add strbmName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

[Pearce]

Thank you gmayor for help.

The following code removes table located in a bookmark named "Bookmark1".

Option Explicit

Sub ClearBookmarks()
Application.ScreenUpdating = False

Dim strFolder As String
Dim strFile As String
Dim wdDoc As Document
Dim oRng As Range

strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)

While strFile <> ""
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    wdDoc.Activate
    With wdDoc
        Set oRng = ActiveDocument.Tables(1).Range
        FillBM_with_Table "Bookmark1", oRng
        Set oRng = Nothing
    End With
    wdDoc.Close SaveChanges:=True
    strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = False
End Sub

Private Sub FillBM_with_Table(strBMName As String, oSource As Range)
'Graham Mayor
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        If oRng.Tables.Count > 0 Then oRng.Tables(1).Delete
        oRng.FormattedText = oSource.FormattedText
        oRng.Bookmarks.Add strBMName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

I have tried to modify the code so that it loops through every bookmark in the document and deletes tables in bookmarks. However so far my attempts have been fruitless. e.g.

Option Explicit

Sub ClearBookmarks()
Application.ScreenUpdating = False

Dim strFolder As String
Dim strFile As String
Dim strName As String
Dim wdDoc As Document
Dim i As Long
Dim oRng As Range

strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)

While strFile <> ""
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    wdDoc.Activate
    With wdDoc
        Set oRng = ActiveDocument.Tables(1).Range
        For i = 1 To ActiveDocument.Bookmarks.Count
            strName = ActiveDocument.Bookmarks(i).Name
            FillBM_with_Table strName, oRng
        Next i
        Set oRng = Nothing
    End With
    wdDoc.Close SaveChanges:=True
    strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = False
End Sub

Private Sub FillBM_with_Table(strBMName As String, oSource As Range)
'Graham Mayor
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        If oRng.Tables.Count > 0 Then oRng.Tables(1).Delete
        oRng.FormattedText = oSource.FormattedText
        oRng.Bookmarks.Add strBMName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Any help or advice would be greatly appreciated.

[gmayor]

To delete tables that are in bookmarks

Sub ClearBookmarks()Dim strFolder As String
Dim strFile As String
Dim strName As String
Dim wdDoc As Document
Dim i As Long
Dim oRng As Range


    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.docx", vbNormal)


    Application.ScreenUpdating = False


    While strFile <> ""
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        wdDoc.Activate
        With wdDoc
            For i = 1 To .Bookmarks.Count
                strBMName = .Bookmarks(i).Name
                Set oRng = .Bookmarks(strBMName).Range
                If oRng.Tables.Count > 0 Then oRng.Tables(1).Delete
                oRng.Bookmarks.Add strBMName
            Next i
            .Close SaveChanges:=True
            Set oRng = Nothing
        End With
        strFile = Dir()
    Wend
    Set wdDoc = Nothing
    Application.ScreenUpdating = True
End Sub

Private Function GetFolder() As String
Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

[Pearce]

Thank you very much!

I have managed to put together a code that copies table from one document and pastes it into antother document into predefined bookmark.

Option Explicit
Option Base 1

Sub CopyTablesFromDoc2Doc()

Dim oSourceDoc As Document
Dim oTargetDoc As Document
Dim oRng As Word.Range


'Optimize Code
    Application.ScreenUpdating = False
  
    Set oSourceDoc = Documents.Open("C:\Source\001_01_Source_VK.docx")
    Set oTargetDoc = Documents.Open("C:\Target\001_01_Target_VK.docx")
    
    With oTargetDoc
        Set oRng = .Bookmarks("TabObce").Range
        oRng.FormattedText = oSourceDoc.Tables(1).Range.FormattedText
        .Bookmarks.Add "TabObce", oRng
        Set oRng = .Bookmarks("TabDemografie").Range
        oRng.FormattedText = oSourceDoc.Tables(2).Range.FormattedText
        .Bookmarks.Add "TabDemografie", oRng
    End With
  
  oSourceDoc.Close
  oTargetDoc.Save
  oTargetDoc.Close

End Sub

I have tried to select the tables from the source document by their title using a function but to no avail. Any piece of advice will be much appreciated.

Sub CopyTablesFromDoc2Doc()

....
    With oTargetDoc
        Set oRng = .Bookmarks("TabObce").Range
        Set oSourceTable = getTableByTitle("TabA")
        oRng = oSourceTable.Range
        oRng.FormattedText = oSourceDoc.Tables(1).Range.FormattedText
....
End Sub

Function getTableByTitle(tabTitle As String) As Table
    Dim shape As Variant

    For Each shape In oSourceDoc.Tables
        If shape.Title = tabTitle Then
            getTableByTitle = shape
            Exit Function
        End If
    Next
End Function

As a next step I will try to incorporate a loop through the source and target documents.

[Pearce]

Today I came across a post by gmayor in the topic "Read Excel Cell from Word VBA" in this forum.

I have used the xlFillArray function to read a worksheet into array. In the worksheet "SourceTarget" in the column A there are listed the source documents (e.g. C:\Source\001_01_Source_VK.docx) and in the column B there are listed the target documents (e.g. C:\Target\001_01_Target_VK.docx).

Option Explicit

Private Const strWorkbook As String = "C:\CopyTables\MatchingTables.xlsx" 'The path of the workbook
Private Const strSheet As String = "SourceTarget" 'The name of the worksheet

Sub CopyTablesFromDocs2Docs()

Dim oSourceDoc As Document
Dim oTargetDoc As Document
Dim oRng As Word.Range
Dim excelArray() As Variant
Dim excelArrayLen As Integer
Dim i As Integer

'Optimize Code
Application.ScreenUpdating = False

excelArray = xlFillArray(strWorkbook, strSheet)

excelArrayLen = UBound(excelArray, 2) - LBound(excelArray, 2) + 1


For i = 1 To excelArrayLen

    Set oSourceDoc = Documents.Open(excelArray(0, i - 1))
    Set oTargetDoc = Documents.Open(excelArray(1, i - 1))
    
    With oTargetDoc
        Set oRng = .Bookmarks("BookmarkA").Range
        oRng.FormattedText = oSourceDoc.Tables(1).Range.FormattedText
        .Bookmarks.Add "BookmarkA", oRng
        Set oRng = .Bookmarks("BookmarkB").Range
        oRng.FormattedText = oSourceDoc.Tables(2).Range.FormattedText
        .Bookmarks.Add "BookmarkB", oRng
    End With
    
    Set oRng = Nothing
    
    oSourceDoc.Close
    oTargetDoc.Save
    oTargetDoc.Close

Next

End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strRange = strRange & "$]"    'Use this to work with a named worksheet
    'strRange = strRange & "]" 'Use this to work with a named range
    Set CN = CreateObject("ADODB.Connection")

    'Set HDR=YES for a sheet or range with a header row
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

I will try to work out the selection of tables from the source documents by their title. I will be glad for any comment/help/advice. Thanks