Consulting

Results 1 to 7 of 7

Thread: Copy tables from documents to another documents with predefined bookmarks

  1. #1

    Copy tables from documents to another documents with predefined bookmarks

    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, ...). Id 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 Id 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 havent found any.
    Any help or advice would be much appreciated.


    Pearce

  2. #2
    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

  3. #3
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    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.

  5. #5
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    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.

  7. #7
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •