Copy Header and footer along with Section text using VBA - vba

I have a Merged-letters Document I need to split it into individual letters.
Following code is doing exactly But it didn't copy the header and footer of each individual page. How can I make it to copy headers and footers along with first section.
Right now it is using oDoc.Sections.First.Range.Cut line to copy the section.
Code:
Sub Splitter_Updated()
' Based on a Macro created 16-08-98 by Doug Robbins to save each letter created by a
' mailmerge as a separate file.
Dim Letters As Long
Dim Counter As Long
Dim Mask As String
Dim DocName As String
Dim oDoc As Document
Dim oNewDoc As Document
Set oDoc = ActiveDocument
oDoc.Save
Selection.EndKey Unit:=wdStory
Letters = Selection.Information(wdActiveEndSectionNumber)
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
DocName = Format(Date, "ddMMyy") _
& "-" & LTrim$(Str$(Counter)) & ".docx"
Debug.Print oDoc.Sections.Count
Debug.Print oDoc.Sections.First.Headers(wdHeaderFooterFirstPage).Range.Text
oDoc.Sections.First.Range.Cut
Set oNewDoc = Documents.Add
'Documents are based on the Normal template
'To use an alternative template follow the link.
With Selection
.Paste
.EndKey Unit:=wdStory
.MoveLeft Unit:=wdCharacter, Count:=1
.Delete Unit:=wdCharacter, Count:=1
End With
oNewDoc.SaveAs FileName:=oDoc.Path & Application.PathSeparator & DocName, AddToRecentFiles:=False
'FileFormat:=wdFormatDocument,
ActiveWindow.Close
Counter = Counter + 1
Wend
oDoc.Close wdDoNotSaveChanges
End Sub

Related

Combine documents from folder

I have a document with several letters separated with section breaks.
What I want to do is to break the document into several ones containing X number of letters (without manually selecting them).
What I have done is to separate it into individual letters with one macro (BreakOnSection), and then combine them with another one (MergeMultiDocsIntoOne) that open a file browser and allows me to select the files I want manually. Below are the macros.
Main Question: If the main document is divided into, let's say, 100 smaller documents, is it possible to modify the second macro, so it selects automatically 10 of them from a folder, merges/combines them creating a new document, and then goes on with another batch of 10, and so on?
First macro:
Sub BreakOnSection()
'Criteria for moving through the document by section.
Application.Browser.Target = wdBrowseSection
'For i = 1 To ((ActiveDocument.Sections.Count) - 1)
For i = 1 To ActiveDocument.Sections.Count
'Copy the whole section
ActiveDocument.Bookmarks("\Section").Range.Copy
'Create a new document to paste text from the clipboard.
Documents.Add
Selection.Paste
'Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
ChangeFileOpenDirectory "C:\Users\MyUser\Desktop\MyFolder"
DocNum = DocNum + 1
ActiveDocument.SaveAs Filename:="letter_" & DocNum & ".docx"
ActiveDocument.Close
'Move the selection to the next section
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
'ActiveDocument.Close savechanges:=wdSaveChanges
End Sub
Second macro:
Sub MergeMultiDocsIntoOne()
Dim dlgFile As FileDialog
Dim nTotalFiles As Integer
Dim nEachSelectedFile As Integer
Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)
With dlgFile
.AllowMultiSelect = True
If .Show <> -1 Then
Exit Sub
Else
nTotalFiles = .SelectedItems.Count
End If
End With
For nEachSelectedFile = 1 To nTotalFiles
Selection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
If nEachSelectedFile < nTotalFiles Then
Selection.InsertBreak Type:=wdPageBreak
Else
If nEachSelectedFile = nTotalFiles Then
Exit Sub
End If
End If
Next nEachSelectedFile
End Sub
Instead of breaking all the Sections into separate documents before recombining them, you'd do far better to simply split the original document into however multi-Section blocks you need. The following code will split any multi-Section document that you might want to break into equal Section counts:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per output document?", "Split By Sections", 1)
With ActiveDocument
' Process each Section
For i = 1 To .Sections.Count - 1 Step j
With .Sections(i)
'*****
' Get the 1st paragraph
Set Rng = .Range.Paragraphs(1).Range
With Rng
' Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & StrTxt
'*****
' Get the whole Section
Set Rng = .Range
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
' Copy the range
.Copy
End With
End With
' Create the output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
' Replicate the headers & footers
For Each HdFt In Rng.Sections(j).Headers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Word document and PDF output are both catered for.
As coded, it is assumed the output filename consists of the first paragraph in each group of Sections. If not, you could use a different range or replace all of the content between the ***** strings with code like:
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & (i + j - 1) / j

How do I split my one document into many at page breaks in VBA?

I am new to VBA. I got this macro from online and it has worked for me before, but now I am getting a runtime error from it.
The macro is supposed to take a mail merged document I have, and split it into individual documents for each recipient.
The runtime error 5487 is pointing me to the line
" .SaveAs fileName:=StrTxt &...".
I have tried to save it as a different file format, and have gone through the other posts on StackOverflow where others have the same error, but I am still getting the error message.
My code is:
Sub SplitMergedDocument()
' Source: http://msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Const StrNoChr As String = """*./\:?|"
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Application.ScreenUpdating = False
j = InputBox("How many Section breaks are there per record?", "Split By Sections ", 1)
With ActiveDocument
For i = 1 To .Sections.Count - 1 Step j ' Process each Section
With .Sections(i)
Set Rng = .Range.Paragraphs(1).Range ' Get 1st paragraph
With Rng
.MoveEnd wdCharacter, -1 'range to exclude final paragraph break
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct destination file path & name
StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
Set Rng = .Range ' Get whole Section
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
.MoveEnd wdCharacter, -1 'Contract range to exclude Section break
.Copy ' Copy range
End With
End With
' Create output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName _
, Visible:=False)
With Doc
' Paste contents into output document, preserving formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
For Each HdFt In Rng.Sections(j).Headers ' Replicate headers & footers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument _
, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Thank you!
Without knowing more (such as the value of StrTxt), I can't say for sure why you're getting the error but it's likely either an invalid filename, or the file is locked by another process, or a permissions issue.
Perhaps the procedure below will work better for you. (I'm unclear on the significance of "records" in your code.)
Split document into separate files for each page:
This procedure splits the ActiveDocument into one .DOCX file per "visible page" (calculated page breaks, manual page breaks, section breaks, etc).\
Sub WordDocToPages()
'splits active Word doc by page into separate DOCX files (same folder as active doc)
Dim doc As Document, docPage As Document, rgPage As Range
Dim pgNum As Long, pgCnt As Long, ext As String, fName As String
Set doc = ActiveDocument 'Use current document
Set rgPage = doc.Range 'create range of 1 page
Application.ScreenUpdating = False 'prevent screen updates
pgCnt = doc.Content.Information(wdNumberOfPagesInDocument) 'get page count
Do While pgNum < pgCnt
pgNum = pgNum + 1 'increment page counter
Application.StatusBar = "Saving page " & pgNum & " of " & pgCnt
If pgNum < pgCnt Then
Selection.GoTo wdGoToPage, wdGoToAbsolute, pgNum + 1 'top of next page
rgPage.End = Selection.Start 'end of page=top of next
Else
rgPage.End = doc.Range.End 'end of last page=EOF
End If
rgPage.Copy 'copy page
Set docPage = Documents.Add(Visible:=False) 'create new document
With docPage
With .Range
.Paste 'paste page
.Find.Execute Findtext:="^m", ReplaceWith:="" 'remove manual breaks
.Select
End With
With Selection
.EndKey wdStory 'goto end of doc
.MoveLeft wdCharacter, 1, wdExtend 'remove final CR
If Asc(.Text) = 13 Then .Delete wdCharacter, 1 'remove trailing CR
End With
ext = Mid(doc.FullName, InStrRev(doc.FullName, ".")) 'extract file extension
fName = Replace(doc.FullName, ext, " #" & _
Format(pgNum, String(Len(CStr(pgCnt)), "0")) & ".docx") 'new filename
.SaveAs fName, wdFormatDocumentDefault 'save single-page doc
.Close 'close new document
End With
rgPage.Collapse wdCollapseEnd 'ready for next page
Loop
Application.ScreenUpdating = True 'resume screen updates
Application.StatusBar = "Document was split into " & pgNum & " files."
Set docPage = Nothing: Set rgPage = Nothing: Set doc = Nothing 'cleanup objects
End Sub
This is loosely based on the example at Usefulware Sharing.
The new files are saved to the same folder as ActiveDocument.Path, with the document title appended with a sequential number. Note that existing output files are overwritten, and there is no validation or error handling.

How to select the first word of a document

I'm trying to write a quick macro, to save my mail merged documents as separate documents, then save each individual document as the first word in each.
Here is what I have so far, to cut the document up, and save it as "Test_1" and so on, but I'm having trouble adding the code to select the first word.
Sub BreakOnSection()
'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.
'Subtracting one from the section count stop error message.
For i = 1 To ((ActiveDocument.Sections.Count) - 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
'To save your document with the original formatting'
Selection.PasteAndFormat (wdFormatOriginalFormatting)
'Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
ChangeFileOpenDirectory "H:\Output"
DocNum = DocNum + 1
ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"
ActiveDocument.Close
'Move the selection to the next section in the document
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub
Any help would be much appreciated.
Can you try this code:
Sub BreakOnSection()
'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.
'Subtracting one from the section count stop error message.
For i = 1 To ((ActiveDocument.Sections.Count) - 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
'To save your document with the original formatting'
Selection.PasteAndFormat (wdFormatOriginalFormatting)
'Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
'Newly Added
'GoTo Starting of the Document
Selection.HomeKey Unit:=wdStory
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=True
Dim FileName As String
FileName = ReplaceIllegalChar(Trim(Selection.Text))
'End
ChangeFileOpenDirectory "H:\Output"
DocNum = DocNum + 1
ActiveDocument.SaveAs FileName:="test_" & FileName & ".doc"
ActiveDocument.Close
'Move the selection to the next section in the document
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub
Function ReplaceIllegalChar(strIn As String) As String
Dim j As Integer
Dim varStr As String, xStr As String
varStr = strIn
For j = 1 To Len(varStr)
Select Case Asc(Mid(varStr, j, 1))
Case 48 To 57, 65 To 90, 97 To 122
xStr = xStr & Mid(varStr, j, 1)
Case Else
xStr = xStr & "_"
End Select
Next
ReplaceIllegalChar = xStr
End Function

Word-VBA: checkbox range

I'm not quite familiar with VBA in general or working with Range. I'd like to add a checkbox after a line of text but the following code outputs all the checkboxes at the very end of the document. I'd think the range parameter in setting the checkbox needs to be fixed but I don't know how to identify it.
'http://wordribbon.tips.net/T010727_Inserting_Multiple_Graphics_in_a_Document.html
Sub GenerateLab()
Dim sPic As String
Dim sPath As String
sPath = "C:\Users\lab\Documents\PDF Gen 12-1\TestImages\"
sPic = Dir(sPath & "*.png")
Do While sPic <> ""
Selection.TypeText ("Is this an ***?")
Selection.TypeParagraph
Selection.TypeText ("***")
Dim objCC As ContentControl
Set objCC = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.TypeParagraph
Selection.TypeText ("Not ***")
Dim objCC2 As ContentControl
Set objCC2 = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.InsertBreak (7)
Loop
End Sub
The problem is not that the checkbox is added at the end of the document but that it's added after the current selection/insertion point (which is the same as the end of the document). Then everything else is added in front of the box and it stays at the end. A short fix would be to move the cursor to the end of the line (or document) by adding the line
Selection.EndKey wdLine
or
Selection.EndKey wdStory
right after .Add.
Another possibility would be to move the cursor 3 characters to the right:
Selection.Move Unit:=wdCharacter, Count:=3
This would be an alternative if you don't add the checkbox at the end of a line.

Get paragraph no where txt is found, and move text to end of paragraph using Word 2010 vba

I am trying to use VBA to move a rich text clause ("strText"), which appears at the beginning of various paragraphs, to the end of each paragraph where the clause appears, and thereafter to underline strText.
I am a novice/hobbyist at vba programming, so please be gentle. I spent a few days on this before seeking help.
Problems with my attempted coding (which appears below):
I tried to assign to var "LparaNo" the number of the paragraph wherein the found text (strText) appears. But the number that "LparaNo" returns is totally off base.
If someone has a suggestion about how to get the right paragraph number, I'd appreciate it.
My intention is to set a range variable objRange_ParaHoldingText= ActiveDocument.Paragraphs(LparaNo).Range, i.e., a range that would reflect the paragraph in which the sought text was found.
I can't figure out how to move objRange01 ("strText", which is formatted text) to the end of the paragraph in which it appears.
Any suggestions would be much appreciated.
Thanks, Marc
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03()
' Code canniablized from http://stackoverflow.com/questions/11733766/how-to-search-for-text-and-check-for-underline-in-vba-for-word
Dim c As Range
Dim fnd As String
Dim strText As String
Dim objRange01 As Range
Dim objRange02 As Range
Dim objRange03 As Range
Dim LparaNo As Long
Dim strParazText As String
With ActiveDocument
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
' My objectives are: (1) to move strText from the beginning of various paragraphs, to the end of each paragraph where it appears,
' and thereafter, (2) to delete the ":" at the end of strText, and (3) to underline strText
fnd = strText
If fnd = "" Then Exit Sub
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = fnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
c.Find.Execute
While c.Find.Found
c.Select ' I am trying to select the text that was found
Set objRange01 = c ' I am trying to set objRange01 = the text that was found, and selected
Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend ' I am extending the selection to include the entire paragraph
Set objRange02 = Selection.Range 'The entire paragraph
Set objRange03 = ActiveDocument.Range(Start:=0, End:=Selection.End) ' I am trying to set objRange02 = all text from
' ' beginning of doc thru objRange01.text
LparaNo = objRange03.ComputeStatistics(wdStatisticParagraphs) + 1 ' I am trying to set LparaNo = the no. of paras in all
' ' text from beginning of doc thru the end of objRange02.
' ' Alas, the number generated for "LparaNo" is incorrect. The paragraph number generated for "LparaNo"
' ' is the number for a paragraph that appears 5 pages before objRange01.text
MsgBox "Paragraph # " & LparaNo & " [objRange01.Text = c = ] " & Chr(34) & objRange01.Text & Chr(34) & vbCrLf & _
vbCrLf & objRange02.Text & vbCrLf & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 2).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 1).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo).Range.Text & vbCrLf ' & _
' ActiveDocument.Paragraphs(LparaNo + 1).Text & vbCrLf & _
' ActiveDocument.Paragraphs(LparaNo + 2).Range.Text & vbCrLf '& _
objRange01.Move Unit:=wdParagraph, Count:=1 ' I am trying unsuccessfully to move the selected text to the beginning
' ' of the next paragraph
objRange01.Move Unit:=wdCharacter, Count:=-1 ' I am trying unsuccessfully to move the selected text from the beginning
' ' of the next paragraph, to the end of the preceding paragraph, i.e.,
' ' to the end of the selected text's paragraph of origin.
c.Find.Execute
Wend ' While c.Find.Found
End With
End Sub 'subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03
Here is a suggestion that doesn't use Find. If you want to use Find, you'll need to loop, which can be tricky if there's any risk of finding the same text more than once. Instead, my solution loops through the Paragraphs collection. Does this get at what you're after?
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_04()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.Content
Dim currPara As Paragraph
Dim strText As String
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
Dim i As Long
' Set a counter to indicate the paragraph. This should be sufficient,
' unless your document is complicated in a way I cannot predict.
i = 0
' Loop through the paragraphs in the active document.
For Each currPara In docRng.Paragraphs
i = i + 1
' Check each paragraph for a match to strText. By using Mid you eliminate
' the chance of finding the string somewhere else in the text. This will work
' for different strText values.
If Mid(currPara.Range.Text, 1, Len(strText)) = strText Then
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End)
' Adds a space at the end of the paragraph. If you don't want the space,
' just delete the InsertAfter method. MoveEnd is used to bring the end of the
' range before the paragraph marker.
With currRng
.MoveEnd Unit:=wdCharacter, Count:=-1
.InsertAfter " "
End With
Set strRng = currDoc.Range(currRng.Start, currRng.Start + Len(strText))
' Set a range for the string, underline it, cut it, paste it at the end of the
' paragraph (again, before the paragraph marker), and select it. Note that moving
' a range doesn't move the text in it. Cut and paste does that.
With strRng
.Underline = wdUnderlineSingle
.Cut
.Move Unit:=wdParagraph, Count:=1
.Move Unit:=wdCharacter, Count:=-1
.Paste
.Select
End With
' Collapse the selection to the end of the text and backspace three times to
' remove the colon and two spaces. If these final characters are variable, you'll
' want something spiffier than this.
With Selection
.Collapse wdCollapseEnd
.TypeBackspace
.TypeBackspace
.TypeBackspace
End With
' Expand the range we've been using to hold the paragraph so that it includes the newly
' pasted text.
currRng.Expand wdParagraph
' I wasn't entirely sure what you wanted to convey in your message box. This displays
' the paragraph number and the new text of the paragraph.
MsgBox "Paragraph # " & i & " [currRng.Text = ] " & Chr(34) & currRng.Text
End If
Next currPara
End Sub