none
VBA Concatenate Files in Multiple Folders RRS feed

  • Question

  • hi friends,

    how is every one doing,

    I have been busy trying to write a vba program for the past week and well I'm no closer to when I started from. I made a little progress but then it started going wrong.

    I would appreciate some advice and help from the kind people here.

    The task is to concatenate merge files in each sub folder

    Example

     SubFolder1
           - 1.docx
           - 2.docx

    SubFolder2
         -a.docx
        - b.docx
        - c.docx

    SubFolder3
         - x.docx
         - y.docx


    End Result :

    In each folder should be the concatenated file.

      SubFolder1.docx
      SubFolder2.docx
      SubFolder3.docx

    I have tried to logically set this out and I have made a lot of mistakes, but because I tried many things,

    I may have mixed it all up as it happens when you try to do a complex task following documentation and testing new things and well I have to now admit defeat :(

    I referenced this thread on Stack that got me started in the right direction - I hope
    http://stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba


    Here is basic code - i have taken out many of the mistakes but there are still a lot

    Option Explicit Sub ConcatenateFolderFiles() Dim FileSystem As Object Dim HostFolder As String Dim oSubFolder As String Dim oSubFile As String Dim oFiletemp As Document Dim oNewWDDoc As Document Dim oDocSource As Document HostFolder = "C:\Users\Dan\Desktop\Combine" ' Main folder holds all the sub folders Set FileSystem = CreateObject("Scripting.FileSystemObject") oSubFolder FileSystem.GetFolder(HostFolder) Application.ScreenUpdating = False For Each oSubFolder In Folder.SubFolders oSubFolder

    ' Put some folder code here

    Next For Each oSubFile In Folder.Files While oSubFile <> "" oNewWDDoc.Range.InsertAfter vbCr & Chr(12) Set oDocSource = Documents.Open(FileName:=oSubFolder & "\" & oSubFile, AddToRecentFiles:=False, Visible:=False) With oDocSource oNewWDDoc.Characters.Last.FormattedText = .Range.FormattedText .Close SaveChanges:=False End With oSubFile = Dir() Wend oFiletemp = Split(oSubFolder, "\") oNewWDDoc.Range.InsertBefore oFiletemp & "Folder" oNewWDDoc.SaveAs2 FileName:=oSubFolder & "\" & oFiletemp & ".docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False Set wdDocSrc = Nothing: Set oNewWDDoc = Nothing ' Add Error Handler Next End Sub


    Is my approach the best approach or is there a better way to achieve this goal?

    There are too many folders at the moment i counted 200+  to concatenate, and if i do one folder at a time  -   I will be stuck until 2020. I looked everywhere on google to help me solve this problem.

     Ive looked at all the vba documentation over and over again and I can't figure out my mistakes.

    Please help I really appreciate your time








        

    Cheers Dan :)

    Thursday, August 4, 2016 1:40 PM

Answers

  • This should get you close.  It only creates a merge doc if there is at least one doc in folder.

    Function Recurse(sPath As String) As String
    
        Dim fso As New FileSystemObject
        Dim myFolder As Folder
        Dim mySubFolder As Folder
        Dim myFile As File
        Dim mergeDoc As Document
        Dim first As Boolean
    
        Set myFolder = fso.GetFolder(sPath)
    
        For Each mySubFolder In myFolder.SubFolders
          Debug.Print mySubFolder.ParentFolder & "\" & mySubFolder.Name
            first = True
            For Each myFile In mySubFolder.Files
              If InStr(myFile.Name, ".doc") > 0 And myFile.Name <> "mergedDoc.docx" Then
                If first Then
                  Set mergeDoc = Documents.Add("C:\temp\b.dotx")
                  mergeDoc.SaveAs FileName:=mySubFolder.ParentFolder & "\" & mySubFolder.Name & "\" & "mergedDoc.docx", _
                  FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
                  first = False
                End If
                Selection.EndKey unit:=wdStory
                Selection.InsertBreak Type:=wdSectionBreakNextPage  'May want this '
                Selection.InsertFile FileName:=myFile
              End If
            Next myFile
            mergeDoc.Repaginate
            mergeDoc.Save
            Recurse = Recurse(mySubFolder.Path)
        Next
    
    End Function
    
    Sub TestR()
    
        Call Recurse("C:\docs")
    
    End Sub
    
    

    • Marked as answer by Dan_CS Monday, August 8, 2016 12:26 PM
    Sunday, August 7, 2016 10:52 PM

All replies

  • I assume you know how to loop through a directory.  Create a template for the base document and continue to add files to it.  xFile is the path to the next docx.  Repaginate the final doc and save.  Merging docs is a pain.  If they switch orientation you need to add a section break.  If someone used non-standard styles like Heading 1 was one font in one doc and another in another.

    Sub test()
          Set mergeDoc = Documents.Add("C:\templates\mergeTemplate.dotx")
          mergeDoc.SaveAs FileName:="C:\docs\mergedDoc.docx", _
                         FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
                         
     '    Loop through directory '
            Selection.EndKey unit:=wdStory
            Selection.InsertBreak Type:=wdSectionBreakNextPage  'May want this'
            Selection.InsertFile FileName:=xFile, Range:="", _
            ConfirmConversions:=False, Link:=False, Attachment:=False
        ' next doc '
          mergeDoc.Repaginate
          mergeDoc.Save
    
    End Sub




    • Edited by mogulman52 Thursday, August 4, 2016 7:53 PM
    Thursday, August 4, 2016 7:43 PM
  • Hello MM,

    thank you for assisting -

    Do i need to use

    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    to make a looping system.

    I referenced this to loop through

    http://stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba

    let me do some testing and see what i can do


    Cheers Dan :)

    Thursday, August 4, 2016 8:06 PM
  • This should loop through one directory.  You do something similar to loop through all the directories.

    Sub test()
    ' add reference to Microsoft Scripting Runtime '
      Dim fldr As Folder
      Dim xFile As File
      Dim fso As New Scripting.FileSystemObject
      
      Set mergeDoc = Documents.Add("C:\templates\mergeTemplate.dotx")
      mergeDoc.SaveAs FileName:="C:\docs\folder1\mergedDoc.docx", _
                     FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
      Set fldr = fso.GetFolder("C:\docs\folder1\") '
      For Each xFile In fldr.Files
        If InStr(xFile.Name, ".docx") > 0 And xFile.Name <> "mergedDoc.docx" Then
          Selection.EndKey unit:=wdStory
          Selection.InsertBreak Type:=wdSectionBreakNextPage  'May want this '
          Selection.InsertFile FileName:=xFile, Range:="", _
          ConfirmConversions:=False, Link:=False, Attachment:=False
        End If
      Next xFile
      mergeDoc.Repaginate
      mergeDoc.Save
    End Sub



    • Edited by mogulman52 Thursday, August 4, 2016 10:49 PM
    Thursday, August 4, 2016 10:45 PM
  • Hi MM,

    I have been fiddling about with the code.

    It created the merged file and then gave this error

     Selection.InsertFile FileName:=xFile, Range:="", _
      ConfirmConversions:=False, Link:=False, Attachment:=False

    I am also trying to work out how i will loop to the next sub folder as

    Public Sub NonRecursiveMethod()
    
    'from stack
    http://stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba
    
        Dim fso, oFolder, oSubfolder, oFile, queue As Collection
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set queue = New Collection
        queue.Add fso.GetFolder("your folder path variable") 'obviously replace
    
        Do While queue.Count > 0
            Set oFolder = queue(1)
            queue.Remove 1 'dequeue
            '...insert any folder processing code here...
            For Each oSubfolder In oFolder.SubFolders
                queue.Add oSubfolder 'enqueue
            Next oSubfolder
            For Each oFile In oFolder.Files
                '...insert any file processing code here...
            Next oFile
        Loop
    
    End Sub

    as i tried to add the code to above to make a loop system for the subfolder that didn't work

    thank you for helping :)


    Cheers Dan :)

    Friday, August 5, 2016 12:00 PM
  • Hi folks,

    I have been testing and tweaking code but unfortunately  - I still have errors on this

    Selection.InsertFile FileName:=xFile, Range:="", _
          ConfirmConversions:=False, Link:=False, Attachment:=False

    File corrupted :(

    I also tried a number of looping systems but the errors are throwing me off course.

    Ok I will persevere and continue -


    Cheers Dan :)


    • Edited by Dan_CS Saturday, August 6, 2016 3:18 PM
    Saturday, August 6, 2016 3:18 PM
  • I just tried this with several docx files and it works.  As an experiment I tried it with a doc file and it worked.  Is xFile a valid path and can you open the doc file with Word.  Just do a simple test case without looping.

    Sub test()
          Set mergeDoc = Documents.Add("C:\templates\mergeTemplate.dotx")
          mergeDoc.SaveAs FileName:="C:\docs\mergedDoc.docx", _
                         FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
                         
    
            Selection.EndKey unit:=wdStory
            
            Selection.InsertFile FileName:="C:\docs\testdoc.docx", Range:="", _
            ConfirmConversions:=False, Link:=False, Attachment:=False
    
          mergeDoc.Repaginate
          mergeDoc.Save
    
    End Sub

    Saturday, August 6, 2016 4:15 PM
  • Hello MM,

    Sub test()
    
    
          Set mergeDoc = Documents.Add("C:\Users\Dan\Desktop\MM\b.dotx")
          mergeDoc.SaveAs FileName:="C:\Users\Dan\Desktop\MM\mergedDoc.docx", _
                         FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
                         
    
            Selection.EndKey unit:=wdStory
            
            Selection.InsertFile FileName:="C:\Users\Dan\Desktop\MM\1.docx", Range:="", _
            ConfirmConversions:=False, Link:=False, Attachment:=False
    
          mergeDoc.Repaginate
          mergeDoc.Save
    
    End Sub
    

    I don't know why the files did not merge, there was no corrupt error file message this time but no merge


    Cheers Dan :)

    Saturday, August 6, 2016 4:27 PM
  • What version of Word do you have?   Does mergeDoc.docx have anything in it? Can you post your template file (b.dotx) and 1.docx file to a file sharing site, like OneDrive with open access?
    Saturday, August 6, 2016 5:51 PM
  • Hi,

    I have word 2016.

    I kept everything simple 1.docx only has 2 paragraphs in it.

    http://jmp.sh/HI0EsDG

    and b.dotx template just basic


    Cheers Dan :)

    Saturday, August 6, 2016 6:49 PM
  • I got b.dotx.  Can you post 1.docx.  I don't have Word 2016.  Maybe that is the problem.
    Sunday, August 7, 2016 12:51 AM
  • oop sorry thought i had posted, it has been a long day with programming and computer playing up

    http://jmp.sh/a2OTKaK


    Cheers Dan :)

    Sunday, August 7, 2016 2:21 AM
  • It worked perfectly for me. I used Word 2010.  Do you have access to an older Word version?  Maybe the issue is with Word 2016.  I removed the optional parameters.  Maybe that is messing up Word 2016.  Please note if the document has a header/footer it will use the header/footer in the template.

    Sub test()
         Dim mergeDoc As Document
    
          Set mergeDoc = Documents.Add("C:\temp\b.dotx")
          mergeDoc.SaveAs FileName:="C:\temp\mergedDoc.docx", _
                         FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
    
            Selection.EndKey unit:=wdStory
            Selection.InsertFile FileName:="C:\temp\1.docx"
    
          mergeDoc.Repaginate
          mergeDoc.Save
    
    End Sub

    Sunday, August 7, 2016 1:21 PM
  • Thank you MM,

    this did not give me an error :)

    Bit by bit getting there.

    I have been working on my loop um but its not going according to plan as it works on the files one by one and i need to merge them in a subfolder. So there is a recursive function that i need to tweak - I probably am not making sense but :

    1. My next task is to point this to 1 sub folder of files -so they all get merged

    2. Final task -  loop through all the sub folders

    ....it will take me some time but, i will try and update on the loop scenario and progress

    :)

    thank you for your help


    Cheers Dan :)

    Sunday, August 7, 2016 1:52 PM
  • I don't understand.  Did it merge the document with the template or not?
    Sunday, August 7, 2016 6:25 PM
  • Hello,

    yes from the code there is only 1 file that was used to test at the moment

    Selection.InsertFile FileName:="C:\Users\Dan\Desktop\MM\1.docx"

    This created a mergedDoc.docx in the folder.

    So now i need to go back to where I can merge all the files in a sub folder, using one of the vba script above provided.


    Cheers Dan :)

    Sunday, August 7, 2016 7:00 PM
  • This should get you close.  It only creates a merge doc if there is at least one doc in folder.

    Function Recurse(sPath As String) As String
    
        Dim fso As New FileSystemObject
        Dim myFolder As Folder
        Dim mySubFolder As Folder
        Dim myFile As File
        Dim mergeDoc As Document
        Dim first As Boolean
    
        Set myFolder = fso.GetFolder(sPath)
    
        For Each mySubFolder In myFolder.SubFolders
          Debug.Print mySubFolder.ParentFolder & "\" & mySubFolder.Name
            first = True
            For Each myFile In mySubFolder.Files
              If InStr(myFile.Name, ".doc") > 0 And myFile.Name <> "mergedDoc.docx" Then
                If first Then
                  Set mergeDoc = Documents.Add("C:\temp\b.dotx")
                  mergeDoc.SaveAs FileName:=mySubFolder.ParentFolder & "\" & mySubFolder.Name & "\" & "mergedDoc.docx", _
                  FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
                  first = False
                End If
                Selection.EndKey unit:=wdStory
                Selection.InsertBreak Type:=wdSectionBreakNextPage  'May want this '
                Selection.InsertFile FileName:=myFile
              End If
            Next myFile
            mergeDoc.Repaginate
            mergeDoc.Save
            Recurse = Recurse(mySubFolder.Path)
        Next
    
    End Function
    
    Sub TestR()
    
        Call Recurse("C:\docs")
    
    End Sub
    
    

    • Marked as answer by Dan_CS Monday, August 8, 2016 12:26 PM
    Sunday, August 7, 2016 10:52 PM
  • Thank you MM so much for all the HELP!!!

    last night I was working on my loop from stack

    Do While queue.Count > 0
            Set oFolder = queue(1)
            queue.Remove 1 'dequeue
            '...insert any folder processing code here...
            For Each oSubfolder In oFolder.SubFolders
                queue.Add oSubfolder 'enqueue
            Next oSubfolder
            For Each oFile In oFolder.Files
                '...insert any file processing code here...
            Next oFile
        Loop

    Although it looked very logical when i tried to include the new code you had written it went pear shaped, so I was stuck for a long time.

    Any way just to say thank you for helping me step by step and being so good and patient with me.

    Programming is not easy that's why I'm trying to learn it so some day  - I will be good at it too and can help others on the forum :)

    You have been a STAR!

    Your recursive folder worked very nicely  - this is exactly what i was trying to achieve from the beginning i had bits of it in the pseudicode  - but nothing cohesive that i could code as there are different ways of doing the same thing.

    I had no idea to use a template the dotx, but that will solve the formatting problem as well so thank you

    Have a very good week my friend

    :) :)

    ok now I'm off to solve some SQL problem on my computer- the server won't uninstall


    Cheers Dan :)

    Monday, August 8, 2016 12:26 PM