Select some parts of text from one Word document and copy into another Word document - vba

I have a word file with some spaces, for example:
Word File XXXXX
Title: XXXXX
etc
And I have another word file which have that data that is missing:
Word File 20248
Title: Example of word file
etc
My question is, how can I use vba to recognize the data from the first file to be copied into the second file in the spaces I want. Furthermore I'd prefer that you can select the word file you want with a dialog box rather than putting in the code where the file is located as I have different files that can have the location changed.
Thank you so much for your answers. I'm pretty new in vba and I have never used it on word.
By now I have this code to choose the word file from which I want to copy the data:
Sub CopyData()
Dim DC As Document
Dim wD As Document, strD As String, wDNumb As Variant
Dim I As Long
Set wD = ActiveDocument
DSelection:
For I = 1 To Documents.Count
strD = strD & Documents(I).Name & " - " & I & vbCrLf
Next I
wDNumb = InputBox("Please, choose the number of the word file from which you are choosing the data to copy:" & vbCrLf & _
vbCrLf & strD, "Choose the word document from which you are copying the data!", 1)
If wDNumb <= Documents.Count And wDNumb >= 1 Then
GoTo DSelection2
ElseIf wDNumb = "" Then MsgBox "Operation cancelled", vbCritical, "Cancelled"
Exit Sub
ElseIf wDNumb > Documents.Count Or wDNumb < 1 Then MsgBox "Wrong number, input a correct number", vbExclamation, "Wrong number"
Exit Sub
End If
DSelection2:
If IsNumeric(wDNumb) Then
Set DC = Documents(CLng(wDNumb))
Else
MsgBox "Please choose the number on the right of the document chosen!": GoTo DSelection
End If
End Sub
I have the following part of the code to copy some part of the Word to the other using bookmarks:
DC.Activate
Set Rng = DC.Range
With Rng.Find
.ClearFormatting
.Execute FindText:="TITLE:", Forward:=True, _
Format:=False, Wrap:=wdFindStop
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdCharacter, 10
.MoveEnd wdSentence, 1
End With
End If
Rng.Select
Selection.Copy
wD.Activate
Selection.GoTo What:=wdGoToBookmark, Name:="TITLE"
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Paste

There are multiple possible ways of approaching this, but your problem description lacks sufficient detail. For example, one could insert:
bookmarks;
content controls;
Section breaks;
tables;
etc.,
into the target document so that content from the source document can be inserted there.
Alternatively, one might use Find/Replace to locate a predefined string that can be replaced with the desired content.
With your updated problem description, you might use:
Dim RngDC As Range, wDRng As Range, BkMkNm As String
BkMkNm "TITLE"
With DC
With .Range.Find
.ClearFormatting
.Execute FindText:=BkMkNm, Forward:=True, Format:=False, Wrap:=wdFindStop
End With
If .Found = True Then
.MoveStart wdCharacter, 10
.MoveEnd wdSentence, 1
Set RngDC = .Duplicate
End If
End With
With wD
Set wDRng = .Bookmarks(BkMkNm).Range
wDRng.FormattedText = RngDC.FormattedText
.Bookmarks.Add BkMkNm, wDRng
End With

Related

Word VBA Loop through bookmarks of similar names

I have a userform that allows users to insert an intentionally blank page after the cover page if they need to print the document. I can get this to work just fine when i only need to insert 1 or 2 blank pages throughout the document, however I now have a new document where i need to insert a total of 14 blank pages if the userform combobox is changed to "Printable Format"
The code i use for the current document is below as reference but I think for adding so many blank pages i'm better to use a loop or find instead of this.
All of my bookmarks for where blank pages are to be added are named "Print" with sequential numbers (ie. "Print 1", Print2" etc) so i was hoping to be able to search through the document for all bookmarks containing the name "Print" but i can't seem to figure it out!
Dim answer As Integer
Dim BMBreak As Range
Dim BMBreak2 As Range
With ActiveDocument
'Insert bookmarks applicable to Printable Format
If CbxPrint.Value = "Printable Format" Then
answer = MsgBox("You have changed the document to Printable Format." & vbNewLine _
& "This will add intentionally blank pages throughout the document " & vbNewLine _
& "Do you wish to continue?", vbOKCancel, "WARNING")
If answer = vbOK Then
'Intentional blank page after title page
Set BMRange = ActiveDocument.Bookmarks("Print1").Range
BMRange.Collapse wdCollapseStart
BMRange.InsertBreak wdPageBreak
BMRange.Text = "THIS PAGE IS INTENTIONALLY BLANK"
BMRange.ParagraphFormat.SpaceBefore = 36
BMRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
ActiveDocument.Bookmarks.Add "Print1", BMRange
With BMRange
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With
With ActiveDocument.Sections(3)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
With ActiveDocument.Sections(2)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterPrimary).Range.Delete
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).Range.Delete
End With ```
Code like the following will process any number of Print# bookmarks (presently limited to 20, which need not all exist):
Dim i As Long, BMRange As Range
With ActiveDocument
If CbxPrint.Value = "Printable Format" Then
If MsgBox("You have changed the document to Printable Format." & vbCr & _
"This will add intentionally blank pages throughout the document " & vbCr _
& "Do you wish to continue?", vbOKCancel, "WARNING") = vbOK Then
'Process bookmarks applicable to Printable Format
For i = 20 To 1 Step -1
If .Bookmarks.Exists("Print" & i) = True Then
'Intentional blank page
Set BMRange = .Bookmarks("Print" & i).Range
With BMRange
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
.InsertBreak Type:=wdSectionBreakNextPage
.Start = .Start - 1
.Sections.Last.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections.Last.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
With .Sections.First
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterPrimary).Range.Delete
.Footers(wdHeaderFooterPrimary).Range.Delete
.Range.InsertBefore "THIS PAGE IS INTENTIONALLY BLANK"
.Range.ParagraphFormat.SpaceBefore = 36
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
.Start = .Start - 1
.Bookmarks.Add "Print" & i, .Duplicate
End With
End If
Next
End If
End If
End With

Convert hyperlinks into footnotes

I currently employ a VBA script to copy all the hyperlinks in an MS Word document and list them in a new document. However, I wonder if there is any way to update this VBA script such that it would translate those hyperlinks into footnotes without affecting the original display words --or live hyperlinks, for that matter. This would be really helpful as copying and pasting those hyperlinks back into the original document is very, very time-consuming. The VBA script I currently have:
Sub PullHyperlinks()
Dim Src As Document
Dim Link As Hyperlink
Dim iDoDisplay As Integer
Set Src = ActiveDocument
If Src.Hyperlinks.Count > 0 Then
iDoDisplay = MsgBox("Include display text for links?", vbYesNo)
Documents.Add DocumentType:=wdNewBlankDocument
For Each Link In Src.Hyperlinks
If iDoDisplay = vbYes Then
Selection.TypeText Link.TextToDisplay
Selection.TypeText vbTab
End If
Selection.TypeText Link.Address
Selection.TypeParagraph
Next Link
Else
MsgBox "There are no hyperlinks in this document."
End If
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range, FtNt As Footnote
With ActiveDocument
For i = .Hyperlinks.Count To 1 Step -1
Set Rng = .Hyperlinks(i).Range
Rng.Collapse wdCollapseStart
Set FtNt = .Footnotes.Add(Rng)
FtNt.Range.FormattedText = .Hyperlinks(i).Range.FormattedText
.Hyperlinks(i).Range.Delete
With FtNt.Range.Hyperlinks(1)
.TextToDisplay = .Address
End With
Next
End With
Application.ScreenUpdating = True
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

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.

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