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

[hrzagi]

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

[rollis13]

Added LINK (https://www.excelforum.com/excel-programming-vba-macros/1342365-vba-to-create-folder-frim-excell-and-save-word-document-in-that-folder.html#post5478646) for cross-posting.

[gmayor]

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

[hrzagi]

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:

[gmayor]

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

[hrzagi]

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 :(

[gmayor]

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

[hrzagi]

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

[hrzagi]

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

[gmayor]

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.

[hrzagi]

Ok, now it works. Thank you :thumb

[hrzagi]

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:

[hrzagi]

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