Consulting

Results 1 to 13 of 13

Thread: VBA to create folder from Excel and save Word document in that folder

  1. #1
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location

    VBA to create folder from Excel and save Word document in that folder

    I have Excell file from where I create and populate bookmarks in Word document. Now I would like to automatically create new folder in c:\ directory named "Test" and subfolder named like cell G13 and to automatically save created word document in that subfolder. I`m not programmer and all this code is scraped from Internet so it would be great if somebody could write needed code and not just give me instructions. I have found code for creating folder but it requires that folder "Test" is already created under c:\ directory. Is there a way to check if folder "Test" exist and if not to create folder and then to check if subfolder exist and if not to create subfolder named like cell G13.

    My code for creating and populating Word document:

    Option Explicit
    
    Sub zapisnikKP()
    Dim pappWord As Object
    Dim docWord As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
    Dim TodayDate As String
    Dim Path As String
    
      Set wb = ActiveWorkbook
      TodayDate = Format(Date, "mmmm d, yyyy")
      Path = wb.Path & "\zapisnikKP.dot"
      
      On Error GoTo ErrorHandler
    
    'Create a new Word Session
      Set pappWord = CreateObject("Word.Application")
      
      On Error GoTo ErrorHandler
    
    'Open document in word
      Set docWord = pappWord.Documents.Add(Path)
        docWord.SaveAs2 "Zapisnik o zaprimanju KP-" & Excel.Names("imePrezimeZrtve").RefersToRange.Value & ".doc"
      
    
    'Loop through names in the activeworkbook
      For Each xlName In wb.Names
        'if xlName's name is existing in document then put the value in place of the bookmark
        If docWord.Bookmarks.Exists(xlName.Name) Then
          docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
        End If
      Next xlName
    
    'Activate word and display document
      With pappWord
          .Visible = True
          .ActiveWindow.WindowState = 0
          .Activate
      End With
    
    'Release the Word object to save memory and exit macro
    ErrorExit:
       Set pappWord = Nothing
       Exit Sub
    
    'Error Handling routine
    ErrorHandler:
       If Err Then
          MsgBox "Error No: " & Err.Number & "; There is a problem"
          If Not pappWord Is Nothing Then
            pappWord.Quit False
          End If
          Resume ErrorExit
       End If
    End Sub
    Code for creating new folder:

      If Len(Dir("c:\Test\" & [G13], vbDirectory)) = 0 Then
       MkDir "c:\Test\" & [G13]
    End If

  2. #2
    VBAX Contributor rollis13's Avatar
    Joined
    Jun 2013
    Location
    Cordenons
    Posts
    146
    Location
    Added LINK for cross-posting.

  3. #3
    The following sub will create the path 'sPath' if not already present. Call it using the code in CreateFolderTest
    Note that the code corrects illegal filename characters in the cell G3 and also for no content in G3.

    Sub CreateFolderTest()
    Dim sFolder As String
        sFolder = CleanFilename(Range("G3"))
        If Not sFolder = "" Then
            CreateFolders "C:\Test\" & sFolder & "\"
        Else
            MsgBox "The cell G3 content is invalid", vbCritical
        End If
    End Sub
    
    
    Private Function CleanFilename(strFileName As String) As String
    'Graham Mayor - https://www.gmayor.com 
    Dim arrInvalid() As String
    Dim lng_Index As Long
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Remove any illegal filename characters
        CleanFilename = strFileName
        For lng_Index = 0 To UBound(arrInvalid)
            CleanFilename = Replace(CleanFilename, Chr(arrInvalid(lng_Index)), Chr(95))
        Next lng_Index
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function CreateFolders(strPath As String)
    'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim strTempPath As String
    
    Dim lng_Path As Long
    Dim VPath As Variant
    Dim oFSO As Object
    Dim i As Integer
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        VPath = Split(strPath, "\")
        If Left(strPath, 2) = "\\" Then
            strPath = "\\" & VPath(2) & "\"
            For lng_Path = 3 To UBound(VPath)
                strPath = strPath & VPath(lng_Path) & "\"
                If Not oFSO.FolderExists(strPath) Then MkDir strPath
            Next lng_Path
        Else
            strPath = VPath(0) & "\"
            For lng_Path = 1 To UBound(VPath)
                strPath = strPath & VPath(lng_Path) & "\"
                If Not oFSO.FolderExists(strPath) Then MkDir strPath
            Next lng_Path
        End If
    lbl_Exit:
        Set oFSO = Nothing
        Exit Function
    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

  4. #4
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    This works like a charm, thank you very much Now, is it possible to automatically save created word document in that folder. So when i click button that word document is opened, populated, and saved in that new folder

  5. #5
    Maybe something like the following in place of the example test macro. Change as appropriate.

    Sub SaveDoc()
    Dim sFolder As String
    Dim sPath As String, sName As String
    Dim wdApp As Object
    Dim oRng As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
        Set wb = ActiveWorkbook
        sFolder = CleanFilename(Range("G3"))
        If Not sFolder = "" Then
            On Error Resume Next
            Set wdApp = GetObject(, "Word.Application")
            If Err Then
                Set wdApp = CreateObject("Word.Application")
            End If
            On Error GoTo 0
            Set docword = wdApp.Documents.Add(wb.path & "\zapisnikKP.dot")
    
            'Loop through names in the activeworkbook
            For Each xlName In wb.Names
                'if xlName's name is existing in document then put the value in place of the bookmark
                If docword.Bookmarks.Exists(xlName.Name) Then
                    Set oRng = docword.Bookmarks(xlName.Name).Range
                    oRng.Text = Range(xlName.value)
                    oRng.Bookmarks.Add xlName.Name
                End If
            Next xlName
            sPath = CreateFolders("C:\Test\" & sFolder & "\")
            sName = CleanFilename(Range("A1"))    'The cell with the document name
            docword.SaveAs2 sPath & sName & ".docx"
        Else
            MsgBox "The cell G3 content is invalid", vbCritical
            Exit Sub
        End If
    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

  6. #6
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    I tried everything but I dont know how to merge that code together Like I said I`m very new in VBA and I tried to google it for answer but everything I try give me errors

  7. #7
    You don't merge anything. You use the code and the two functions I originally posted in place of your code.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  8. #8
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    When I run it excel create folder with proper name, open word document and fill it out and then I got "Run-time error 5153" "the program cannot give the name of the document as it already has an open document with same name"

    Sub Main()
    CreateFolderTest
    zapisnikKP
    SaveDoc
    End Sub
    Sub CreateFolderTest()
    Dim sFolder As String
        sFolder = CleanFilename(Range("G13"))
        If Not sFolder = "" Then
            CreateFolders "C:\Test\" & sFolder & "\"
        Else
            MsgBox "The cell G13 content is invalid", vbCritical
        End If
    End Sub
    
    Private Function CleanFilename(strFileName As String) As String
    'Graham Mayor - https://www.gmayor.com
    Dim arrInvalid() As String
    Dim lng_Index As Long
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Remove any illegal filename characters
        CleanFilename = strFileName
        For lng_Index = 0 To UBound(arrInvalid)
            CleanFilename = Replace(CleanFilename, Chr(arrInvalid(lng_Index)), Chr(95))
        Next lng_Index
    lbl_Exit:
        Exit Function
    End Function
    Private Function CreateFolders(strPath As String)
    'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim strTempPath As String
    Dim lng_Path As Long
    Dim VPath As Variant
    Dim oFSO As Object
    Dim i As Integer
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        VPath = Split(strPath, "\")
        If Left(strPath, 2) = "\\" Then
            strPath = "\\" & VPath(2) & "\"
            For lng_Path = 3 To UBound(VPath)
                strPath = strPath & VPath(lng_Path) & "\"
                If Not oFSO.FolderExists(strPath) Then MkDir strPath
            Next lng_Path
        Else
            strPath = VPath(0) & "\"
            For lng_Path = 1 To UBound(VPath)
                strPath = strPath & VPath(lng_Path) & "\"
                If Not oFSO.FolderExists(strPath) Then MkDir strPath
            Next lng_Path
        End If
    lbl_Exit:
        Set oFSO = Nothing
        Exit Function
    End Function
    Sub zapisnikKP()
    Dim pappWord As Object
    Dim docWord As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
    Dim TodayDate As String
    Dim Path As String
      Set wb = ActiveWorkbook
      TodayDate = Format(Date, "mmmm d, yyyy")
      Path = wb.Path & "\zapisnikKP.dot"
      
      On Error GoTo ErrorHandler
    'Create a new Word Session
      Set pappWord = CreateObject("Word.Application")
      
      On Error GoTo ErrorHandler
    'Open document in word
      Set docWord = pappWord.Documents.Add(Path)
      docWord.SaveAs2 "Obavijest doga?aj-" & Excel.Names("imePrezimeZrtve").RefersToRange.Value & ".doc"
      
    'Loop through names in the activeworkbook
      For Each xlName In wb.Names
        'if xlName's name is existing in document then put the value in place of the bookmark
        If docWord.Bookmarks.Exists(xlName.Name) Then
          docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
        End If
      Next xlName
    'Activate word and display document
      With pappWord
          .Visible = True
          .ActiveWindow.WindowState = 0
          .Activate
      End With
    'Release the Word object to save memory and exit macro
    ErrorExit:
       Set pappWord = Nothing
       Exit Sub
    'Error Handling routine
    ErrorHandler:
       If Err Then
          MsgBox "Error No: " & Err.Number & "; There is a problem"
          If Not pappWord Is Nothing Then
            pappWord.Quit False
          End If
          Resume ErrorExit
       End If
    End Sub
    Sub SaveDoc()
    Dim sFolder As String
    Dim sPath As String, sName As String
    Dim wdApp As Object
    Dim oRng As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
        Set wb = ActiveWorkbook
        sFolder = CleanFilename(Range("G13"))
        If Not sFolder = "" Then
            On Error Resume Next
            Set wdApp = GetObject(, "Word.Application")
            If Err Then
                Set wdApp = CreateObject("Word.Application")
            End If
            On Error GoTo 0
            Set docWord = wdApp.Documents.Add(wb.Path & "\zapisnikKP.dot")
            'Loop through names in the activeworkbook
            For Each xlName In wb.Names
                'if xlName's name is existing in document then put the value in place of the bookmark
                If docWord.Bookmarks.Exists(xlName.Name) Then
                    Set oRng = docWord.Bookmarks(xlName.Name).Range
                    oRng.Text = Range(xlName.Value)
                    oRng.Bookmarks.Add xlName.Name
                End If
            Next xlName
            sPath = CreateFolders("C:\Test\" & sFolder & "\")
            sName = CleanFilename(Range("G13"))    'The cell with the document name
            docWord.SaveAs2 sPath & sName & ".docx"
        Else
            MsgBox "The cell G13 content is invalid", vbCritical
            Exit Sub
        End If
    End Sub
    
    Last edited by hrzagi; 02-27-2021 at 03:00 PM.

  9. #9
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    https://www.dropbox.com/s/1a8xp9ged1swadx/PROBA.7z?dl=0
    This is simple version of program that I use just for testing.

  10. #10
    It is not surprising that it crashed, as you didn't do what I said. The sub and the two functions I posted are ALL that you need. You appear to have at least two macros trying to do similar things without closing the document, so you are trying to save the document with a document already created by another version of the code, which is still open.
    I have added code to close the document so that if you run it twice it won't crash. See attached.
    Attached Files Attached Files
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  11. #11
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    Ok, now it works. Thank you

  12. #12
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    Just one more thing
    It would be great if document is opened after saving so I could review it immediately and do whatever I need to do with it.


  13. #13
    VBAX Regular
    Joined
    Jan 2021
    Posts
    65
    Location
    Ok, this is how I managed to open document after saving.
      With wdApp
          .Visible = True
          .ActiveWindow.WindowState = 0
          .Activate
      End With
    'Release the Word object to save memory and exit macro
    ErrorExit:
        Set wdApp = Nothing
        Exit Sub
    Last edited by hrzagi; 03-18-2021 at 02:44 AM.

Posting Permissions

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