How to select the first word of a document - vba

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

Related

Copy Header and footer along with Section text using 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

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

Save documents with the data from mail merge

For my work I make product specifications. I have a table with all the data, and a standard Word document where the data needs to be inserted. I do this using the built-in mail merge function from Word. However, I need to save the documents seperately, and I found the following code for this:
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
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:\"
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
This saves the documents as test 1, test 2, etc.
I want to save the documents using one of the data items I use for the mail merge. Is there any way to do this?
I made it work, this is the code I have now
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
Selection.Paste
Dim rngParagraphs As Range
Set rngParagraphs = ActiveDocument.Range(Start:=(ActiveDocument.Paragraphs(1).Range.Start + 6), End:=(ActiveDocument.Paragraphs(1).Range.End - 1))
rngParagraphs.Select
' 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:\"
DocNum = DocNum + 1
ActiveDocument.SaveAs FileName:="Productspec" & rngParagraphs & ".doc"
ActiveDocument.Close
' Move the selection to the next section in the document
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub

Color of new MS Word hyperlink is black and I want it to be blue

I'm an amateur at vba for Word.
My macro (below) creates a hyperlink from selected text, but the new hyperlink is black, whereas a hyperlink that I create using MS Word's menu, is blue.
I want my macro to create hyperlinks that are blue too.
As you'll see in my macro (below), I've not been able to get the hyperlinks to be blue.
Any suggestions would be much appreciated.
Marc
Here's the macro:
Sub subHyprlinkSrch4PdfFiles_aaa()
'
' subHyprlinkSrch4PdfFiles_aaa Macro
'
'
Dim strTextToDisplay As String
Dim rngSelection As RAnge
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.MoveLeft Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Set rngSelection = ActiveDocument.Selection.RAnge
Application.Selection.Font.ColorIndex = wdBlue
strTextToDisplay = Application.Selection.Text
ActiveDocument.Hyperlinks.Add Anchor:=Selection.RAnge, Address:="" _
, SubAddress:="", ScreenTip:="", TextToDisplay:=strTextToDisplay
Application.Selection.Style = wdStyleHyperlink
Application.Selection.Font.ColorIndex = wdBlue
With rngSelection
.Font.ColorIndex = wdBlue
End With
End Sub 'subHyprlinkSrch4PdfFiles_aaa()
Here's the sub that I fixed with the solution User Don Jewett gave me yesterday, Nov. 2, 2016 (below):
Sub subHyperlinkSelectedTextaaa() 'Hyperlink to a file whatever text you selected.
'Hyperlink to a file whatever text you selected.
' http://www.wiseowl.co.uk/blog/s209/type-filedialog.htm
Dim Sel01 As Selection
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim iFileChosen As Integer
Dim strFileFullname As String
Dim Txt2Display As String
Set Sel01 = Application.Selection
If Sel01.Type <> wdSelectionIP Then ' i.e., if the selection is valid, i.e., characters are selected
Txt2Display = Sel01.Text
'MsgBox Txt2Display
Else
MsgBox "No characters were selected validly; so this macro will terminate now."
Exit Sub
End If 'If Sel01.Type <> wdSelectionIP Then ' i.e., if the selection is valid, i.e., characters are selected
' Open FileDialog "fd" and select a file
iFileChosen = fd.Show
If iFileChosen <> -1 Then
'You didn't choose anything (clicked on CANCEL)
MsgBox "You chose cancel, or something prevented the file-selection-dialog from operating property."
Else
strFileFullname = CStr(fd.SelectedItems(1))
'MsgBox strFileFullname
End If
' http://stackoverflow.com/questions/40388765/color-of-new-ms-word-hyperlink-is-black-and-i-want-it-to-be-blue
With Application.Selection
.Font.ColorIndex = wdBlue
'ActiveDocument.Hyperlinks.Add Selection.Range, .Text, "", "", .Text
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
strFileFullname, SubAddress:="", ScreenTip:="", TextToDisplay:=Txt2Display
.Style = wdStyleHyperlink
End With
End Sub 'subHyperlinkSelectedTextaaa()
If you want to create a hyperlink using the selected text as the link and text, this should work fine:
Sub subHyprlinkSrch4PdfFiles_aaa()
With Application.Selection
.Font.ColorIndex = wdBlue
ActiveDocument.Hyperlinks.Add Selection.Range, .Text, "", "", .Text
.Style = wdStyleHyperlink
End With
End Sub

Export individual documents from mail merge

How would I create individuals files from mail merge rather than the one large file that is output by the mail merge function in Microsoft Office?
I was hoping to be able to save each letter than was created as a name of one of the merge fields, but I haven't been able to find an intuitive way so far...
Recently I've come across the similar situation where I want to save individual files in pdf format rather than saving one large file created by Mail merge function. I've written down this small function to save individual file in pdf format.
Sub SaveAsPDF()
Dim CouncilName As String
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
For SectionCount = 1 To .DataSource.RecordCount
With .DataSource
'FirstRecord and LastRecords defines how many data records needs to be merge in one document.
'createing pdf file for each data record so in this case they are both pointing to ActiveRecord.
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
'get the council name from data source
CouncilName = .DataFields("Council").Value
'move to next datasource record.
If .ActiveRecord <> .RecordCount Then
.ActiveRecord = wdNextRecord
End If
End With
'Get path and file name
PDFPathAndName = ActiveDocument.Path & Application.PathSeparator & "FINAL - " & CouncilName & ".pdf"
' Merge the document
.Execute Pause:=False
' Save resulting document.
Set PDFFile = ActiveDocument
PDFFile.ExportAsFixedFormat PDFPathAndName, wdExportFormatPDF
PDFFile.Close 0
Next
End With
End Sub
as of my experience, there is no option to save individual files, instead you can use Macro to spit the files and save it individually with specific name that you want. I have tried the same and succeeded with what want. Hope the below code helps you as well to achieve you goal.
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 "C:\"
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
Please revert me for any clarifications.
I modified Parth's answer since it didn't work for me.
Sub SaveAsFileName()
Dim FileName As String
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
For SectionCount = 1 To .DataSource.RecordCount
With .DataSource
ActiveDocument.MailMerge.DataSource.ActiveRecord = SectionCount
ActiveDocument.MailMerge.DataSource.FirstRecord = SectionCount
ActiveDocument.MailMerge.DataSource.LastRecord = SectionCount
' replace Filename with the column heading that you want to use - can't have certain symbols in the name
FileName = .DataFields("Filename").Value
End With
'Get path and file name
FullPathAndName = ActiveDocument.Path & Application.PathSeparator & FileName & ".docx"
' Merge the document
.Execute Pause:=False
' Save resulting document.
ActiveDocument.SaveAs (FullPathAndName)
ActiveDocument.Close False
Next
End With
End Sub