How can I truncate a footer to the first 15 characters? Word 2010 vba
I am splitting a word document with multiple letters to individual files. The text I want to use as the filename is in the first 14 characters of the footer.
I need to truncate the footer to name the files.
I am very new to vba, any help would be greatly appreciated.
Below is my code :
Sub BreakOnPVOHSection()Dim letter As RangeDim fname As RangeDim target As DocumentDim strFileName As StringDim strID As String ' Used to set criteria for moving through the document by section. Application.Browser.target = wdBrowseSection'A mailmerge document ends with a section break next page. For i = 1 To ((ActiveDocument.Sections.Count) - 1) Set fname = ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range fname.End = fname.End - 1 'Select and copy the section text to the clipboard ActiveDocument.Bookmarks("\Section").Range.Copy 'Create a new document to paste text from clipboard. Documents.Add Selection.Paste ' ActiveDocument.Bookmarks = Mid(fname, 0, 12) ChangeFileOpenDirectory "\\vcuhshmo\users\lheaton\bpa" docnum = docnum + 1 ActiveDocument.SaveAs fileName:=fname.Text & ".docx" ActiveDocument.Close savechanges:=wdDoNotSaveChanges ' Move the selection to the next section in the document Application.Browser.Next Next i ActiveDocument.Close savechanges:=wdDoNotSaveChangesEnd Sub
Sub BreakOnPVOHSection()Dim strFileName As StringDim docNew As DocumentDim sec As SectionDim docA As DocumentDim rng As RangeDim docnum As Integer Set docA = ActiveDocument 'capture initial active document into an object variable, 'so that we don't have to keep track of which document is currently active'A mailmerge document ends with a section break next page.For Each sec In docA.Sections 'truncate and delete any paragraph marks strFileName = Replace(Left(sec.Footers(wdHeaderFooterPrimary).Range, 14), vbCr, "") Set rng = sec.Range If Len(rng) = 1 Then 'last section Exit For End If rng.MoveEnd wdCharacter, -1 'drop section break rng.Copy 'Create a new document to paste text from clipboard. Set docNew = Documents.Add docNew.Range.Paste docnum = docnum + 1 'docNew.SaveAs FileName:="\\vcuhshmo\users\lheaton\bpa\" & strFileName & ".docx" docNew.SaveAs FileName:="C:\MyFolder\" & strFileName & ".docx" docNew.Close savechanges:=wdDoNotSaveChangesNext sec docA.Close savechanges:=wdDoNotSaveChangesEnd Sub
The naming works beautifully, thank you. But it's stripping out the header, footer and formatting that are needed. I will add those parts back in and see how it goes!!! Thank you so much for resolving this naming thing. Whew!
jbndylan
ASKER
I'm sorry. I was not clear regarding the header/footer. Those I want to keep. Only for the filename do I want to include the first 14 characters of the footer. The names your code came up with are perfect.
Open in new window