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:

Code:

---

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:

Code:

---

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

---

Added LINK for cross-posting.

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.

Code:

---

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

---

This works like a charm, thank you very much :thumb 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 :think:

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

Code:

---

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

---

I tried everything but I dont know how to merge that code together :doh:Like I said I`m very new in VBA and I tried to google it for answer but everything I try give me errors :(

You don't merge anything. You use the code and the two functions I originally posted in place of your code.

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"

Code:

---

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


---

https://www.dropbox.com/s/1a8xp9ged1swadx/PROBA.7z?dl=0
This is simple version of program that I use just for testing.

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.

Ok, now it works. Thank you :thumb

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. :think:

Ok, this is how I managed to open document after saving.

Code:

---

  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

---