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