none
Create Multiple documents from a template document RRS feed

  • Question

  • Good Day All,

    I am relatively new to VBA and recently got allocated to a task at work which I believe could be done effectively with a macro.

    I have created a document which has macro crucial for the business functions. These macros need to be applied to more than 200 documents which have the same structure (5 tables) as the document with macro (I will call it Template document going forward). However table 2 in every document has different content, so <g class="gr_ gr_626 gr-alert gr_tiny gr_spell gr_inline_cards gr_run_anim ContextualSpelling multiReplace" data-gr-id="626" id="626">i</g> decided to copy the table to the template document and rename the document as the document it was copied from to a different folder and save it and do the same for the remainder of the documents. But I am struck at copying the content from the source document to the template as it doesn't

    sub copydata()
    Dim oSource as Document
    Dim oTarget as Document
    Dim oTable as Table
    
    Set oSource = ActiveDocument
    Set oTarget = Documents.open(document1)
    
    With oTarget
    .Tables(2).cells(2,2).Range.text = oSource.Tables(2).cell(2,2).Range.text
    End With
    End Sub

     give me a satisfactory result. For instance, attempting to copy a cell data from template file to source file result in copying of the content and a carriage return which distrupts structure. I would like help or some sort of direction on how to proceed;

    1. to copy the table content from the source document to template document

    2. after the copy function, save the template document with the source document name in a different folder

    3. is it possible to create a loop that does the above two for all files in a folder.

    Please let me know if I have clearly explained my needs for your understanding.

    Any help will be greatly appreciated.

    Thanks for your time.

    Althaf

    Thursday, August 3, 2017 1:14 PM

Answers

  • Hi Dev_Alan,

    You could iterate through cells in the table and set text for each cell.

    Here is the example.

    Sub UpdateDocumentTables()

    Application.ScreenUpdating = False

    Dim sourceTable As Table

    Dim targetTable As Table

    Dim doc As Document

    Dim tmp As Document

    fromFolder = "C:\Users\Desktop\FromFolder"

    tofolder = "C:\Users\Desktop\ToFolder"

    sourceFile = Dir(fromFolder & "\*.docx", vbNormal)

    tempFile = "C:\Users\Desktop\FileTemp.dotx"

    Set tmp = Documents.Open(FileName:=tempFile, Visible:=True)

    Set targetTable = tmp.Tables(2)

    While sourceFile <> ""

        Set doc = Documents.Open(FileName:=fromFolder & "\" & sourceFile, Visible:=False)

        Set sourceTable = doc.Tables(2)

        For i = 1 To sourceTable.Range.Cells.Count

        targetTable.Range.Cells(i).Range.Text = _

                        sourceTable.Range.Cells(i).Range.Text

         Next i

        doc.Close savechanges:=False

         tmp.SaveAs2 FileName:=tofolder & "\" & sourceFile, fileformat:=wdFormatDocumentDefault

         sourceFile = Dir()

    Wend

    tmp.Close savechanges:=True

    Application.ScreenUpdating = True

    End Sub

    Best Regards,

    Terry

    • Marked as answer by Dev_Alan Tuesday, August 8, 2017 5:51 AM
    Friday, August 4, 2017 6:59 AM
  • Try:

    Sub ApplyDocumentTables()
    Application.ScreenUpdating = False
    Dim strInFolder As String, strOutFolder As String
    Dim strFile As String, strDocNm As String, i As Long
    Dim DocSrc As Document, TblSrc As Table, RngSrc As Range
    Dim DocTgt As Document, TblTgt As Table, RngTgt As Range
    strDocNm = ThisDocument.FullName
    strInFolder = "C:\Users\Desktop\InputFolder\"
    strOutFolder = "C:\Users\Desktop\OutputFolder\"
    strFile = Dir(strInFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strInFolder & strFile <> strDocNm Then
        Set DocSrc = Documents.Open(FileName:=strInFolder & strFile, AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
        Set TblSrc = DocSrc.Tables(2)
        Set DocTgt = Documents.Add(Template:=strDocNm, Visible:=False)
        With DocTgt
          Set TblTgt = .Tables(2)
          With TblTgt.Range
            For i = 1 To .Cells.Count
              Set RngTgt = .Cells(i).Range
              Set RngSrc = TblSrc.Range.Cells(i).Range
              RngTgt.End = RngTgt.End - 1: RngSrc.End = RngSrc.End - 1
              If Len(RngSrc.Text) > 0 Then
                RngTgt.FormattedText = RngSrc.FormattedText
              Else
                RngTgt.Delete
              End If
            Next
          End With
          .SaveAs2 FileName:=strOutFolder & strFile, FileFormat:=wdFormatXMLDocumentMacroEnabled, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
        DocSrc.Close SaveChanges:=False
      End If
      strFile = Dir()
    Wend
    Set RngTgt = Nothing: Set TblTgt = Nothing: Set DocTgt = Nothing
    Set RngSrc = Nothing: Set TblSrc = Nothing: Set DocSrc = Nothing
    Application.ScreenUpdating = True
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by Dev_Alan Tuesday, August 8, 2017 12:08 PM
    Tuesday, August 8, 2017 11:50 AM

All replies

  • Try the running following macro from the document containing the new tables. It includes a folder browser, so all you need do is select the folder to process.

    Sub UpdateDocumentTables()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, i As Long
    Dim DocSrc As Document, TblSrc As Table, RngSrc As Range
    Dim DocTgt As Document, TblTgt As Table, RngTgt As Range
    Set DocSrc = ActiveDocument: strDocNm = DocSrc.FullName
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strFolder & "\" & strFile <> strDocNm Then
        Set DocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        With DocTgt
          For i = 1 To 5
            If i <> 2 Then
              Set RngTgt = .Tables(i).Range
              With RngTgt
                .Tables(1).Delete
                .FormattedText = DocSrc.Tables(i).Range.FormattedText
              End With
            End If
          Next
          Set TblSrc = .Tables(2)
          With TblSrc.Range
            .Start = .Start - 1
            .Collapse wdCollapseStart
            .InsertAfter vbCr & vbCr & vbCr
            .Characters(2).FormattedText = DocSrc.Tables(2).Range.FormattedText
            Set TblTgt = .Tables(1)
            With TblTgt.Range
              For i = 1 To .Cells.Count
                Set RngTgt = .Cells(i).Range
                Set RngSrc = TblSrc.Range.Cells(i).Range
                RngTgt.End = RngTgt.End - 1: RngSrc.End = RngSrc.End - 1
                If Len(RngSrc.Text) > 0 Then
                  RngTgt.FormattedText = RngSrc.FormattedText
                Else
                  RngTgt.Delete
                End If
              Next
            End With
          End With
          With TblSrc.Range
            .Start = TblTgt.Range.End
            .Delete
          End With
          .Close SaveChanges:=True
        End With
      End If
      strFile = Dir()
    Wend
    Set RngTgt = Nothing: Set TblTgt = Nothing: Set DocTgt = Nothing
    Set RngSrc = Nothing: Set TblSrc = Nothing: Set DocSrc = Nothing
    Application.ScreenUpdating = True
    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
    Note: As coded, the macro updates all 5 tables. If you only want to update the 2nd table, simply delete or comment-out the entire For i = 1 To 5 ... Next loop.


    Cheers
    Paul Edstein
    [MS MVP - Word]



    • Edited by macropodMVP Saturday, August 5, 2017 2:59 AM
    Friday, August 4, 2017 12:56 AM
  • Hi Dev_Alan,

    You could iterate through cells in the table and set text for each cell.

    Here is the example.

    Sub UpdateDocumentTables()

    Application.ScreenUpdating = False

    Dim sourceTable As Table

    Dim targetTable As Table

    Dim doc As Document

    Dim tmp As Document

    fromFolder = "C:\Users\Desktop\FromFolder"

    tofolder = "C:\Users\Desktop\ToFolder"

    sourceFile = Dir(fromFolder & "\*.docx", vbNormal)

    tempFile = "C:\Users\Desktop\FileTemp.dotx"

    Set tmp = Documents.Open(FileName:=tempFile, Visible:=True)

    Set targetTable = tmp.Tables(2)

    While sourceFile <> ""

        Set doc = Documents.Open(FileName:=fromFolder & "\" & sourceFile, Visible:=False)

        Set sourceTable = doc.Tables(2)

        For i = 1 To sourceTable.Range.Cells.Count

        targetTable.Range.Cells(i).Range.Text = _

                        sourceTable.Range.Cells(i).Range.Text

         Next i

        doc.Close savechanges:=False

         tmp.SaveAs2 FileName:=tofolder & "\" & sourceFile, fileformat:=wdFormatDocumentDefault

         sourceFile = Dir()

    Wend

    tmp.Close savechanges:=True

    Application.ScreenUpdating = True

    End Sub

    Best Regards,

    Terry

    • Marked as answer by Dev_Alan Tuesday, August 8, 2017 5:51 AM
    Friday, August 4, 2017 6:59 AM
  • Hi Paul,

    Thank you heaps for your reply and sample code. Please accept my apologies for late correspondance.

    I was stuck in a training till Monday and hence couldnt get around to the issue.

    I ran your code and it works fine until opening the files and there are I am not sure what is happening with the code.

    the requirement was to copy table 2 contents from target document and paste it to activedocument or source document and save it as a new file in a different location (as .docm this was not mentioned in the intial request).

    When I ran your code I was expecting it to do the following

    1. run the code from activedocument or source document 

    2. point to the folder where target document is stored

    3.the macro will open target document and copy the table 2 and paste it in source or active document and save it in the same location as the target document

    Steps 1 and 2 worked fine but the step 3 didnt seem to work as the target documents didnt have any macros at all.

    If I have done it incorrectly or failed to follow your instruction, could you please advise?

    Many thanks again for your time in looking onto my issue.

    Kindly

    Althaf

    Tuesday, August 8, 2017 5:07 AM
  • Hi Terry,

    Thank you heaps for your reply and sample code. Please accept my apologies for late <g class="gr_ gr_26 gr-alert gr_spell gr_inline_cards gr_run_anim ContextualSpelling ins-del multiReplace" data-gr-id="26" id="26">correspondance</g>.

    I was stuck in a training till Monday and hence <g class="gr_ gr_24 gr-alert gr_spell gr_inline_cards gr_run_anim ContextualSpelling ins-del multiReplace" data-gr-id="24" id="24">couldnt</g> get around to the issue.

    The sample code you have provided works a charm. <g class="gr_ gr_27 gr-alert gr_gramm gr_inline_cards gr_run_anim Grammar multiReplace" data-gr-id="27" id="27">Only</g> issue I have is that every cell in table 2 has a carriage return. Is there a way to overcome this ? and the saveas2 line that reads as below in your code

     tmp.SaveAs2 FileName:=tofolder & "\" & sourceFile, fileformat:=wdFormatDocumentDefault

    is changed to 

     tmp.SaveAs2 FileName:=tofolder & "\" & sourceFile & ".docm", fileformat:=wdFormatXMLDocumentMacroEnabled

    The issue I have with this, the new file is saved as document1.doc.docm. How can I overcome this so the new file name reads <g class="gr_ gr_567 gr-alert gr_gramm gr_inline_cards gr_run_anim Punctuation multiReplace" data-gr-id="567" id="567">document1.docm.</g> 

    Otherwise it works excellent.

    Thanks again for your time again.

    Kindly

    Althaf


    • Edited by Dev_Alan Tuesday, August 8, 2017 6:36 AM Edit#
    Tuesday, August 8, 2017 5:51 AM
  • As indicated in my previous reply, you are intended to run the macro from the document containing the new tables. It is assumed all 5 tables are in that document. A potentially significant difference between the code I posted and Terry X's code is that mine retains any mixed font formatting of the original table 2 content, while Terry X's code loses it.

    With the original code I posted, you'd have to copy all the files to your output folder before running the macro - I missed the part about saving to a different folder. Consequently, it's the original files that get updated - and saved back to their original format. No matter, that can be accommodated with the following version:

    Sub UpdateDocumentTables()
    Application.ScreenUpdating = False
    Dim strInFolder As String, strOutFolder As String, i As Long
    Dim strFile As String, strDocNm As String, sFmt As Long
    Dim DocSrc As Document, TblSrc As Table, RngSrc As Range
    Dim DocTgt As Document, TblTgt As Table, RngTgt As Range
    Set DocSrc = ActiveDocument: strDocNm = DocSrc.FullName
    strInFolder = "C:\Users\Desktop\InputFolder\"
    strOutFolder = "C:\Users\Desktop\OutputFolder\"
    strFile = Dir(strInFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strInFolder & strFile <> strDocNm Then
        Set DocTgt = Documents.Open(FileName:=strInFolder & strFile, AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
        With DocTgt
          sFmt = .SaveFormat
          For i = 1 To 5
            If i <> 2 Then
              Set RngTgt = .Tables(i).Range
              With RngTgt
                .Tables(1).Delete
                .FormattedText = DocSrc.Tables(i).Range.FormattedText
              End With
            End If
          Next
          Set TblSrc = .Tables(2)
          With TblSrc.Range
            .Start = .Start - 1
            .Collapse wdCollapseStart
            .InsertAfter vbCr & vbCr & vbCr
            .Characters(2).FormattedText = DocSrc.Tables(2).Range.FormattedText
            Set TblTgt = .Tables(1)
            With TblTgt.Range
              For i = 1 To .Cells.Count
                Set RngTgt = .Cells(i).Range
                Set RngSrc = TblSrc.Range.Cells(i).Range
                RngTgt.End = RngTgt.End - 1: RngSrc.End = RngSrc.End - 1
                If Len(RngSrc.Text) > 0 Then
                  RngTgt.FormattedText = RngSrc.FormattedText
                Else
                  RngTgt.Delete
                End If
              Next
            End With
          End With
          With TblSrc.Range
            .Start = TblTgt.Range.End
            .Delete
          End With
          .SaveAs2 FileName:=strOutFolder & strFile, FileFormat:=sFmt, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
      End If
      strFile = Dir()
    Wend
    Set RngTgt = Nothing: Set TblTgt = Nothing: Set DocTgt = Nothing
    Set RngSrc = Nothing: Set TblSrc = Nothing: Set DocSrc = Nothing
    Application.ScreenUpdating = True
    End Sub

    Edit the strInFolder & strOutFolder variables to suit your requirements.

    It's not apparent why you'd want to automatically save all the documents in the docm format, though; that's generally only appropriate if they're already in that format. The revised code retains the original file formats.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Tuesday, August 8, 2017 7:06 AM
  • Hi Paul,

    Thanks again for your swift reply.

    As Suggested, I ran your macro from the file which has all the macros and the tables of interest. I am not sure if I have misinterpreted my intentions in my initial request. The whole idea is to copy content of table 2 from a source document( this document is in .doc file format) to the template document (the document with all the macros, <g class="gr_ gr_1117 gr-alert gr_spell gr_inline_cards gr_run_anim ContextualSpelling ins-del multiReplace" data-gr-id="1117" id="1117">activex</g> <g class="gr_ gr_1125 gr-alert gr_gramm gr_inline_cards gr_run_anim Punctuation only-ins replaceWithoutSep" data-gr-id="1125" id="1125">control</g> buttons and tables which <g class="gr_ gr_461 gr-alert gr_gramm gr_inline_cards gr_run_anim Grammar multiReplace" data-gr-id="461" id="461">is</g> in .docm file format) and after the copy of table 2 save the template document with the source document name and .docm file format.

    I ran the macro again and noticed that content of table 2 is copied to template document. But when the template file is being saved it deletes the active x control buttons in table 3 and table 4. Further, all the other macros in the template file have been removed. Otherwise, the code is perfect.

    Please help me understand why the active x controls and other macros have been removed from the final saved copy.

    Cheers

    Althaf


    • Edited by Dev_Alan Tuesday, August 8, 2017 8:35 AM Re-run
    Tuesday, August 8, 2017 8:23 AM
  • Regarding tables other than table 2, see the Note following the code in my initial reply. The same comment applies to the updated macro. From your original post, I was under the impression you may have wanted to replace all 5 tables in the documents being processed with the corresponding tables in your new document. The Note tells you how to update only the 2nd table.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Tuesday, August 8, 2017 10:28 AM
  • I agree with your comment about my initial post. The issue I am facing is that the the macro is doing the reverse of what I wanted. For instance, it updates the source document and saves it whilst I wanted the template document to be updated and saved with the source file name. I am trying to decode your code (as it brilliantly updates all tables without a carriage return) to do it so that the new document has all the macro modules. But I have to agree I am out of luck. Is there a way, I can upload the documents for your reference?

    Thanks Again

    Althaf

    Tuesday, August 8, 2017 10:42 AM
  • Try:

    Sub ApplyDocumentTables()
    Application.ScreenUpdating = False
    Dim strInFolder As String, strOutFolder As String
    Dim strFile As String, strDocNm As String, i As Long
    Dim DocSrc As Document, TblSrc As Table, RngSrc As Range
    Dim DocTgt As Document, TblTgt As Table, RngTgt As Range
    strDocNm = ThisDocument.FullName
    strInFolder = "C:\Users\Desktop\InputFolder\"
    strOutFolder = "C:\Users\Desktop\OutputFolder\"
    strFile = Dir(strInFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strInFolder & strFile <> strDocNm Then
        Set DocSrc = Documents.Open(FileName:=strInFolder & strFile, AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
        Set TblSrc = DocSrc.Tables(2)
        Set DocTgt = Documents.Add(Template:=strDocNm, Visible:=False)
        With DocTgt
          Set TblTgt = .Tables(2)
          With TblTgt.Range
            For i = 1 To .Cells.Count
              Set RngTgt = .Cells(i).Range
              Set RngSrc = TblSrc.Range.Cells(i).Range
              RngTgt.End = RngTgt.End - 1: RngSrc.End = RngSrc.End - 1
              If Len(RngSrc.Text) > 0 Then
                RngTgt.FormattedText = RngSrc.FormattedText
              Else
                RngTgt.Delete
              End If
            Next
          End With
          .SaveAs2 FileName:=strOutFolder & strFile, FileFormat:=wdFormatXMLDocumentMacroEnabled, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
        DocSrc.Close SaveChanges:=False
      End If
      strFile = Dir()
    Wend
    Set RngTgt = Nothing: Set TblTgt = Nothing: Set DocTgt = Nothing
    Set RngSrc = Nothing: Set TblSrc = Nothing: Set DocSrc = Nothing
    Application.ScreenUpdating = True
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by Dev_Alan Tuesday, August 8, 2017 12:08 PM
    Tuesday, August 8, 2017 11:50 AM
  • You are a legend. Works a charm.

    Cant thank you enough.

    Cheers

    Althaf

    Tuesday, August 8, 2017 12:11 PM
  • I ran the code to modify more than 150 documents and it worked perfectly. Thank you heaps for your patience in resolving my situation I had before. After creating the documents, I realised that the macro used to create the documents has been passed on to all 150+ files and I sincerely apologise for not able to think about this issue earlier. This led me to the thought of running the macro from excel and did the below variation to it and I get the error "Runtime error 438". Could you please help me understand what I am doing incorrectly to overcome the issue and run the macro from excel.

    Sub apply_Tempate()
    Dim wordapp As Object
    Dim strInFolder As String, strOutFolder As String
    Dim strFile As String, strDocNm As Variant, i As Long
    Dim DocSrc As Object, TblSrc As Object, RngSrc As Object
    Dim DocTgt As Object, TblTgt As Object, RngTgt As Object
    Set wordapp = CreateObject("word.application")
    strDocNm = "C:\Template file.docm"
    strInFolder = "C:\InFolder"
    strOutFolder = "C:\OutFolder"
    strFile = Dir(strInFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strInFolder & strFile <> strDocNm Then
        Set DocSrc = wordapp.Documents.Open(Filename:=strInFolder & strFile, AddtoRecentfiles:=False, Visible:=True, ReadOnly:=True)
        Set TblSrc = wordapp.DocSrc.Tables(2)
        Set DocTgt = wordapp.Documents.Add(Template:=strDocNm, Visible:=True)
        With DocTgt
          Set TblTgt = .Tables(2)
          With TblTgt.Range
            For i = 1 To .Cells.Count
              Set RngTgt = .Cells(i).Range
              Set RngSrc = .Range.Cells(i).Range
              RngTgt.End = RngTgt - 1: RngSrc.End = RngSrc.End - 1
              If Len(RngSrc.Text) > 0 Then
                RngTgt.FormattedText = RngSrc.FormattedText
              Else
                RngTgt.Delete
              End If
            Next
          End With
          .SaveAs2 Filename:=strOutFolder & strFile, FileFormat:=wdFormatXMLDocumentMacroEnabled, AddtoRecentfiles:=False
          .Close SaveChanges:=False
        End With
        DocSrc.Close SaveChanges:=False
      End If
      strFile = Dir()
    Wend
    Set RngTgt = Nothing: Set TblTgt = Nothing: Set DocTgt = Nothing
    Set RngSrc = Nothing: Set TblSrc = Nothing: Set DocSrc = Nothing
    Application.ScreenUpdating = True
    End Sub

    Hope I have not added too much work with this.

    Thanks in advance.

    Althaf


    • Edited by Dev_Alan Wednesday, August 9, 2017 4:06 AM newinfo
    Wednesday, August 9, 2017 4:05 AM
  • The simplest solution would be to not put the table macro code into the 'template' document; instead, using the code from my last post, run it from another document and change:

    strDocNm = ThisDocument.FullName

    to reference your 'template' document, much as you have done with:

    strDocNm = "C:\Template file.docm"


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Proposed as answer by macropodMVP Wednesday, August 9, 2017 6:17 AM
    Wednesday, August 9, 2017 4:42 AM
  • You are a life saver.

    As before worked a charm!

    Thanks again

    Althaf

    Wednesday, August 9, 2017 5:46 AM