none
Select the Main Folder - Word Macros VBA RRS feed

  • Question

  • Hi all,

    I am new to macros. I found this macro that  merges documents in a folder on a forum, but i dont know what to do to fix it.

    I wanted to know if I am able to select the folder.

    At the moment i have to type folder names.

    there are a lot of folders and they are long folder names and i have made mistakes so the folder does not get combined.

    its a good program it works nicely but you have to type the folder name each time other wise it wont work.

    I found this  here


    ttp://windowssecrets.com/forums/showthread.php/175508-Create-Combined-Documents-in-each-folder/page2

    this is the code

    Sub CombineFolderDocuments()
    'Paul Edstein

    Application.ScreenUpdating = False
    Dim strSubFolder, strFolder As String, strFile As String, StrTmp
    Dim wdDocTgt As Document, wdDocSrc As Document, i As Long

          strFolder = "C:\Users\" & Environ("Username") & "\Desktop\CombineFolder\"
          strSubFolder = Array(" Folder1", "Folder2,"Folder3,"Folder4,")

    For i = 0 To UBound(strSubFolder)
      strFile = Dir(strFolder & strSubFolder(i) & "\*.doc", vbNormal)
      Set wdDocTgt = Documents.Add(Visible:=False)
      While strFile <> ""
        wdDocTgt.Range.InsertAfter vbCr & Chr(12)
        Set wdDocSrc = Documents.Open(FileName:=strFolder & strSubFolder(i) & "\" & strFile, _
          AddToRecentFiles:=False, Visible:=False)

        With wdDocSrc
          wdDocTgt.Characters.Last.FormattedText = .Range.FormattedText
          .Close SaveChanges:=False
        End With
        strFile = Dir()
      Wend
      StrTmp = Split(strSubFolder(i), "\")(UBound(Split(strSubFolder(i), "\"))) & "_" & Format(Now, "YYYY-MM-DD")

      With wdDocTgt
        .Range.InsertBefore StrTmp & " Backup"

        .SaveAs2 FileName:=strFolder & strSubFolder(i) & "\" & StrTmp & ".docx", _
        Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
        .Close False
      End With
    Next
    Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
    Application.ScreenUpdating = True

    End Sub


    I have researched on google but did not find anything thats says what to do.

    I am new to macros so please do be gentle

    thank you very much


                  
    Tuesday, May 3, 2016 8:24 PM

All replies

  • The following allows you to select the required folders. Unfortunately, AFAIK, there is no way of making a multiple selection of folders like you can with files so they need to be selected one at a time and appended to the array. Run the code and select the required folder and it will loop ready for you to select the next folder and will continue to loop for you to select the next folder until you click the cancel button.

    I have added a MsgBox loop so you can view the selections made. This is just for your testing and as per the comments in the code you can delete it. I have not tested the code past where I have inserted the "Stop". When you are satisfied that you can select folders then you can delete the stop and you can test further.

    Note that the selected folders actually contain the entire path so do not concatenate with the parent folder. I have deleted the parent folder out of the remainder of your code.

    Sub CombineFolderDocuments()
     'Paul Edstein

        Application.ScreenUpdating = False
        Dim strSubFolder, strFile As String, StrTmp     'strFolder removed
        Dim wdDocTgt As Document, wdDocSrc As Document, i As Long
       
        Dim SelectedFolder As Variant  'Must be variant
        Dim a As Long   'for array elements
       
        a = 1   'Initialize array element counter to 1
        'Create one based array (ie.elements count from one instead of zero)
        ReDim strSubFolder(1 To a)  'Initialize array with one element otherwise ReDim preserve does not work
        Do
            With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = "Select required folder. Cancel when finished."
                .AllowMultiSelect = False   'Can only select one folder at a time.
                If .Show = True Then        'Clicking Cancel button sets .Show to False
                    ReDim Preserve strSubFolder(1 To a)
                    strSubFolder(a) = .SelectedItems(1)
                    a = a + 1
                Else
                    MsgBox "User exited by clicking cancel."    'This line for testing only. Can be deleted
                    Exit Do
                End If
            End With
        Loop
       
        '*********************************************************
        'Code between asterisklines for testing only. Delete after testing
        For a = LBound(strSubFolder) To UBound(strSubFolder)
            MsgBox strSubFolder(a)
        Next a
        '*********************************************************

    Stop        'halts the processing until selection of folders has been tested. Delete after testing

     For i = 0 To UBound(strSubFolder)
       'The array elements contain the entire path so don't concatenate with strFolder
       strFile = Dir(strSubFolder(i) & "\*.doc", vbNormal)  'strFolder deleted from this line
       Set wdDocTgt = Documents.Add(Visible:=False)
       While strFile <> ""
         wdDocTgt.Range.InsertAfter vbCr & Chr(12)
         'strFolder removed from following line
         Set wdDocSrc = Documents.Open(FileName:=strSubFolder(i) & "\" & strFile, _
           AddToRecentFiles:=False, Visible:=False)

         With wdDocSrc
           wdDocTgt.Characters.Last.FormattedText = .Range.FormattedText
           .Close SaveChanges:=False
         End With
         strFile = Dir()
       Wend
       StrTmp = Split(strSubFolder(i), "\")(UBound(Split(strSubFolder(i), "\"))) & "_" & Format(Now, "YYYY-MM-DD")

       With wdDocTgt
         .Range.InsertBefore StrTmp & " Backup"

         'StrFolder removed from following line
         .SaveAs2 FileName:=strSubFolder(i) & "\" & StrTmp & ".docx", _
         Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
         .Close False
       End With
     Next
     Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
     Application.ScreenUpdating = True

     End Sub


    Regards, OssieMac

    Wednesday, May 4, 2016 4:32 AM
  • Hello OssieMac,

    its so nice of you to help me with programming.

    I selected the folders - it worked a treat.

    but no documents got combined

    :(

    did I mess it up and not do it right

    thank you for your help


    • Edited by mabbott5 Wednesday, May 4, 2016 12:05 PM
    Wednesday, May 4, 2016 11:45 AM
  • What happened? Did the code stop with an error? If so, what is the error?

    As per my previous post, I did not test past the Stop which you would need to remove for the rest of the code to process. Not having the example files, it is difficult to work through the processing code to combine the files (or whatever it is you are attempting to do with them).

    I see one error in your code example with the following line because I dimensioned a one based array so cannot commence with zero.

     For i = 0 To UBound(strSubFolder)

    the line should be as follows:

    For i = 1 To UBound(strSubFolder)

    I actually prefer to use LBound for the first element and UBound for the last element and then it does not matter if the array is zero based or one based. Example as follows.

     For i = LBound(strSubFolder) To UBound(strSubFolder)


    Regards, OssieMac

    Thursday, May 5, 2016 6:46 AM
  • Hello dear,

    I paste the new line you showed into the code.

    it now combines the documents -  but it inserts 45 blank pages before the combined documents. I wonder why it does that?

    I will have to delete the blank pages.

    Here is the code

    Sub CombineFolderDocuments()
    technet

        Application.ScreenUpdating = False
        Dim strSubFolder, strFile As String, StrTmp     'strFolder removed
        Dim wdDocTgt As Document, wdDocSrc As Document, i As Long
       
        Dim SelectedFolder As Variant  'Must be variant
        Dim a As Long   'for array elements
       
        a = 1   'Initialize array element counter to 1
        'Create one based array (ie.elements count from one instead of zero)
        ReDim strSubFolder(1 To a)  'Initialize array with one element otherwise ReDim preserve does not work
        Do
            With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = "Select required folder. Cancel when finished."
                .AllowMultiSelect = False   'Can only select one folder at a time.
                If .Show = True Then        'Clicking Cancel button sets .Show to False
                    ReDim Preserve strSubFolder(1 To a)
                    strSubFolder(a) = .SelectedItems(1)
                    a = a + 1
                Else
                    'MsgBox "User exited by clicking cancel."    'This line for testing only. Can be deleted
                    Exit Do
                End If
            End With
        Loop
       
     For i = 1 To UBound(strSubFolder)
     
       'The array elements contain the entire path so don't concatenate with strFolder
       strFile = Dir(strSubFolder(i) & "\*.doc", vbNormal)  'strFolder deleted from this line
       Set wdDocTgt = Documents.Add(Visible:=False)
       While strFile <> ""
         wdDocTgt.Range.InsertAfter vbCr & Chr(12)
         'strFolder removed from following line
         Set wdDocSrc = Documents.Open(FileName:=strSubFolder(i) & "\" & strFile, _
           AddToRecentFiles:=False, Visible:=False)

         With wdDocSrc
           wdDocTgt.Characters.Last.FormattedText = .Range.FormattedText
           .Close SaveChanges:=False
         End With
         strFile = Dir()
       Wend
       StrTmp = Split(strSubFolder(i), "\")(UBound(Split(strSubFolder(i), "\"))) & "_" & Format(Now, "YYYY-MM-DD")

       With wdDocTgt
         .Range.InsertBefore StrTmp & " Backup"

         'StrFolder removed from following line
         .SaveAs2 FileName:=strSubFolder(i) & "\" & StrTmp & ".docx", _
         Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
         .Close False
       End With
     Next
     Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
     Application.ScreenUpdating = True

     End Sub

    I do apologise a lot i dont have a clue what an aray is or the Lbound - i did try to understand it but it was difficult to know exactly what it is

    thank you for helping me

    do you have a clue what all those blank pages are about

    My test condition 1 put

    2 basic document into a folder 1

    2 basic document folder 2

    then i run the test

    the document was created in the folder  - but it had all those blank pages before it so i had to scroll al the way down

    thank you

    :)

    Thursday, May 5, 2016 1:56 PM