Split document then save with specific file names

[HTSCF Fareha]

I have been scouring the internet to find a sub macro solution or something that comes close, but so far have found nothing that fits my requirements.

Those that I have found have focussed on mailmerge or will not divide the document into the required separated documents and/or have produced documents that have broken the existing page format and design.

I have a three page document that has been populated via VBA UserForm (as attached). This needs to be separated into two separate documents with fixed file names. The first document should consist of the first two pages and the second from the final third page. Document one shall be named "breakdown report.docx" and the second "repair plan.docx", which will be saved in a specific folder located at "C:\Users\Repair\Documents\Breakdowns".

Many thanks!
Steve

[macropod]

You could, of course, save your document, then:
• make two copies of it; and
• open each copy in turn and delete the unwanted content...

[gmayor]

Based on your example, the following should work, however Windows security will almost certainly not allow you to save to that path (unless the User name is 'Repair'). Use the path in the example instead. You can call the macro from your process, however it might be simpler just to create two documents from the outset.



Sub SaveLetter(oDoc As Document)
Dim oTempDoc As Document
Dim oRng As Range
Dim sPath As String
Const strName1 As String = "breakdown report.docx"
Const strName2 As String = "repair plan.docx"
sPath = Environ("USERPROFILE") & "\Repair\Documents\Breakdowns\"
CreateFolders sPath
oDoc.Save
Set oRng = oDoc.Range(0, 0)
Selection.GoTo What:=wdGoToPage, which:=wdGoToNext, Name:="2"
oRng.End = ActiveDocument.Bookmarks("\page").Range.End
Set oTempDoc = Documents.Add(Template:=oDoc.FullName)
oTempDoc.Range.FormattedText = oRng.FormattedText
oTempDoc.Range.Find.Execute findText:="^m", Replacewith:="", Replace:=wdReplaceAll
oTempDoc.SaveAs2 sPath & strName1
oRng.Collapse 0
oRng.End = oDoc.Range.End
Set oTempDoc = Documents.Add(Template:=oDoc.FullName)
oTempDoc.Range.FormattedText = oRng.FormattedText
oTempDoc.SaveAs2 sPath & strName2
oDoc.Close 0
lbl_Exit:
Set oTempDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub


Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
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

[HTSCF Fareha]

Many thanks Graham for taking a look at this.

In my original description I should've added that the two documents are currently created separately. The need to have them created at once is to improve efficiency as a number of entries are repeated across both.

You are correct in the User name and this was an oversight on my part. I left your code as is and was allowing it to run. Unfortunately I am getting a "argument not optional" on the line calling the sub 'SaveLetter'.

I'm certain that I'm probably calling the sub wrong or something else that should be obvious, but I am not seeing it I'm afraid. I would really appreciate a nudge in the right direction!

Thanks again.
Steve

[gmayor]

The argument that is not optional is the document 'oDoc'. If this is the active document then you call it adding the document to save e.g.


SaveLetter ActiveDocument

[HTSCF Fareha]

Thanks, Graham.

Okay, I've ammended as per your previous post. Unfortunately I initially get a prompt box to save the document(s). If I cancel this and ignore this prompt (gives a runtime error '4198' command failed), the two documents are saved correctly in the correct folder. Almost there!

Thanks!
Steve

Could I please send the document to you via personal email (content is sensitive so not able to post here)?

[macropod]

In my original description I should've added that the two documents are currently created separately. The need to have them created at once is to improve efficiency as a number of entries are repeated across both.
But that is no reason to combine the documents, only to have to separate them again later...
Both could be opened together - as separate documents - and updated together without all this quite unnecessary circumlocution.

[HTSCF Fareha]

I tweaked your code a bit Graham, so that it removed the prompt to save the initital document. This initial document is also not required at the end, so have added a couple of lines to close then delete this.


Sub SaveLetter(oDoc As Document)
Dim oTempDoc As Document
Dim oRng As Range
Dim sPath As String
Const strName1 As String = "breakdown report.docx"
Const strName2 As String = "repair plan.docx"
Const strName3 As String = "Temp.docx"
sPath = Environ("USERPROFILE") & "\Repair\Documents\Breakdowns\"
CreateFolders sPath
oDoc.SaveAs2 sPath & strName3 ' Create temporary document
'oDoc.Save
Set oRng = oDoc.Range(0, 0)
Selection.GoTo What:=wdGoToPage, which:=wdGoToNext, Name:="2"
oRng.End = ActiveDocument.Bookmarks("\page").Range.End
Set oTempDoc = Documents.Add(Template:=oDoc.FullName)
oTempDoc.Range.FormattedText = oRng.FormattedText
oTempDoc.Range.Find.Execute findText:="^m", Replacewith:="", Replace:=wdReplaceAll
oTempDoc.SaveAs2 sPath & strName1
oRng.Collapse 0
oRng.End = oDoc.Range.End
Set oTempDoc = Documents.Add(Template:=oDoc.FullName)
oTempDoc.Range.FormattedText = oRng.FormattedText
oTempDoc.SaveAs2 sPath & strName2
'oDoc.Close 0
Documents(strName3).Close ' Close temporary document
Kill sPath & strName3 ' Delete temporary document
lbl_Exit:
Set oTempDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

This has on the whole got me to where I want it. The only annoying thing now is that the UserForm insists on showing itself twice more at the end! Here is the code at the start and end of the Fill Form code.


Option Explicit

Private m_oFrm As frmNFAMalCom

Private Sub Document_New()
Set m_oFrm = New frmNFAMalCom
m_oFrm.Show
If m_oFrm.Tag = "Enter" Then FillForm
lbl_Exit:
'Unload m_oFrm
Set m_oFrm = Nothing
Exit Sub
End Sub

Sub FillForm()
Dim oCtrl As Control
Dim oCC As ContentControl
Dim lngIndex As Long
Dim strTC As String

CreatedDate

With m_oFrm
.
.
.
.
.
lbl_Exit:

SaveLetter ActiveDocument

Exit Sub

End Sub


Any help very much appreciated.

Thanks!
Steve

[HTSCF Fareha]

This is so near, but I just cannot stop the UserForm from wanting to show itself after being run once. I have to press the 'Cancel' button on my UserForm twice (when this appears) then I get the required result of being left with only the two created documents open.

Thanks!
Steve

[gmayor]

Change the macro in the ThisDocument folder to



Option Explicit


Private Sub Document_New()
FillForm
lbl_Exit:
Set m_oFrm = Nothing
Exit Sub
End Sub
In a normal module

Option Explicit


Private m_oFrm As frmNFAMalCom


Sub FillForm()


Dim oCtrl As Control
Dim oCC As ContentControl
Dim lngIndex As Long
Dim strTC As String
CreatedDate
Set m_oFrm = New frmNFAMalCom
With m_oFrm
.Show
.
.
.
.
End With
lbl_Exit:
SaveLetter ActiveDocument
Exit Sub
End Sub

[HTSCF Fareha]

Thanks for hanging in there with me Graham!

Alas, I have implemented the code / module as suggested but still end up with the UserForm showing twice at the end, requiring pressing the 'Cancel' button for each time it pops up.

I appreciate that this is not the done thing, but I would please like to provide a password protected compressed zip file containing my form, then send the password via PM if I may?

Apologies if this breaches any Forum rules.

Steve