I have a large document in word, around 800 pages, which I need to apply some formating after finding a person's name within the text.
The text will look like the below.
01/01/1999, 09:00 - Joe Bloggs:
I want to find "Joe Bloggs" in the entire document and then apply formatting to make it bold and Tahoma font to not only the name but the date and time before the name which I believe is 20 characters.
Can anybody help with what may be a simple problem?
Just using Find/Replace in Word (no VBA) you can
Open Find/Replace
Click the More button to expose the Use Wildcards option
Select the Use Wildcards option
For Find What enter ([!¤]{20,20}Joe Bloggs)
For Replace with enter \1 then click the Format button to change to Bold Tahoma. You should see Tahoma, bold below the replace box.
Now do normal Find Next, Replace, Replace All as you see fit.
Note: the ¤ character in the Find What search can be any character you're sure is NOT in your target text.
This will work for what you described (Joe Bloggs: and move 20 characters to the left).
Public Sub Main()
Dim oRng As Range
With Selection
'''move selectiont to start of document
.HomeKey Unit:=wdStory
With .Find
.Text = "Joe Bloggs:"
.ClearFormatting
.MatchWildcards = False
.Wrap = wdFindStop
Do While .Execute
Set oRng = Selection.Range
With oRng
.MoveStart Unit:=wdCharacter, Count:=-20
.Font.Name = "Tahoma"
End With
Selection.MoveRight
Loop
End With
End With
End Sub
Related
When converting a table from PDF to word, I ended up with a format similar to the following:
([space] is a space character)
Text [space.spacing 10pts] Text [space.spacing 30pts] Text
Text [space.spacing 14pts] Text [space.spacing 31pts] Text
Text [space.spacing 12pts] Text [space.spacing 33pts] Text
Instead of a regular table with 3 columns and 3 rows containing each « Text » such as below
Text
Text
Text
Text
Text
Text
Text
Text
Text
In other words, instead of creating a column, the PDF conversion has created a regular paragraph, mimicking columns by adjusting [spaces].spacing according to the length of the text within the column.
So my inital thought was that it should be possible to recreate a table by identifing the spacing of each space for each paragraph of the converted table, eventually replacing them with identifiable symbols so I can convert the text into a table later on.
My idea was somewhat the following :
' For each paragraph of the selected text (which is the converted table)
' Find all [space] within the paragraph range
' If a [space] is found, check its spacing
' 1st case : [space].spacing is <= 1 pts (so a normal space)
' Do nothing
' 2nd case : [space].spacing is >= 10 pts (so previous Text is supposed to be within a small column)
' insert ££ (symbol for small column)
' 3rd case [space].spacing is >= 30 pts (so previous Text is supposed to be within a small column)
' insert §§ (symbol for large column)
' Once all [space] are found within the current paragraph, do the same with the next paragraph, until the last paragraph of the selected text
My current code is the following :
Private Sub Test()
Dim RngSearch As Range
Dim RngCurrent As Range
Dim Paragraph As Paragraph
For Each Paragraph In ActiveDocument.Paragraphs
Set RngCurrent = Paragraph.Range
RngCurrent.Select 'For testing purposes
With RngCurrent.Find
.Text = " "
Do While RngCurrent.Find.Execute
RngCurrent.Select 'For testing purposes
Select Case RngCurrent.Font.Spacing
Case Is >= 30
RngCurrent.Font.Spacing = 1
RngCurrent.InsertAfter ("§§")
Case Is >= 10
RngCurrent.Font.Spacing = 1
RngCurrent.InsertAfter ("¤")
Case Else
' Do Nothing
End Select
Loop
End With
Next Paragraph
End Sub
So it kinda word with one issue : it loops infinitely. Each time the text is finished, it goes back again indefinitely.
I managed to track the issue to the following code :
With RngCurrent.Find
.Text = " "
Do While RngCurrent.Find.Execute
RngCurrent.Select
' Use Case function
Loop
End With
Without it, the looping through paragraphs works normally (it ends at the last paragraph)
For Each Paragraph In ActiveDocument.Paragraphs
Set RngCurrent = Paragraph.Range
RngCurrent.Select
' Code here
Next Paragraph
But once .find.text (" ") is injected, it actually doesn't look within each Paragraphs.Range anymore as I supposed Do While RngCurrent.Find.Execute should have established.
I feel like the solution is something very stupid, but I've been searching for the reason why or alternatives for 2 days now. Everytime, it stops acting as per my understading when I'm using .find(" ").
I already tried using .wrap = wdFindStop, but it stops at the first match within the paragraph, and goes to the next paragraph prematurely.
With RngCurrent.Find
.Text = " "
.wrap = wdFindStop
Do While RngCurrent.Find.Execute
RngCurrent.Select
' Use Case function
Loop
End With
Strangely .wrap = wdFindAsk doesn't ask me anything... maybe that means something.
I believe it's because there are always spaces within each paragraph ? So it can loops indefinitely?
You're way over-complicating things:
Sub MakeTable()
Application.ScreenUpdating = False
Dim i As Single
With Selection
i = .Characters.First.Font.Size
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.Text = " "
.Replacement.Text = "^t"
.Replacement.Font.Size = i
.Font.Size = 10
.Execute Replace:=wdReplaceAll
.Font.Size = 30
.Execute Replace:=wdReplaceAll
End With
.ConvertToTable Separator:=vbTab
End With
Application.ScreenUpdating = True
End Sub
So I finally found not exactly a solution but a workaround for anyone who may need a similar solution. Instead of using a .find =" ", I decided to go the "hard" path and check for every word in a paragraph (which in MS Word, seems to end with a [space] character). Then, I check for the last character of a word (which is often a space) if its spacing is superior to a value. It the case, do something.
For Each RngWord In Paragraph.Range.Words
Set RngChar = RngWord.Characters.Last
Select Case RngChar.Font.Spacing
Case Is > 300
RngChar.Font.Spacing = 1
RngChar.InsertAfter ("£")
Case Is > 100
RngChar.Font.Spacing = 1
RngChar.InsertAfter ("#")
Case Is > 15
RngChar.Font.Spacing = 1
RngChar.InsertAfter ("¤")
Case Else
' Do Nothing
End Select
Next RngWord
It does the job, and isn't that slow, but I guess there are better solution :)
I would like to add captions to figures where chapters would be included in the numbering, and the text "Figure x.x." was bold:
Figure 1.1. Sample figure.
Autocaptions is not possible because it will only allow for styles named Heading 1-9 to be considered as chapters, while I am using a custom style. As I understand, there is no way to include any personalised style to the list.
Please take into consideration that my knowledge of VBA is virtually nonexistant (I usually try to find a similar problem in multiple forums and adapt it using guides or other similar solved problems), so my error might be trivial for those who are more experienced. I could manage to write a macro to do almost everything I needed, but there is this one thing that is not working as expected.
Ideally, the macro would:
Prompt the user to select an image
Insert the image with a specific paragraph style
Insert a caption that includes chapter number with a custom paragraph style, instead of builtin ones
Search for "Figure x.x." text and make it bold using Find and Replace with wildcards <== This is where I'm having problems
Sub PicCaption()
Dim intChoice As Integer
Dim strPath As String
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
End If
'insert the image
Selection.InlineShapes.AddPicture FileName:= _
strPath, LinkToFile:=False, _
SaveWithDocument:=True
Selection.Range.Style = "Figures"
'Add caption in the form of "Figure x.x. "
Selection.TypeParagraph
Selection.TypeText Text:="Figure "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"STYLEREF ChapNum \n \t", PreserveFormatting:=False
Selection.TypeText Text:="."
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"SEQ Figure \* ARABIC", PreserveFormatting:=False
Selection.TypeText Text:="."
Selection.Style = ActiveDocument.Styles("Figures")
Selection.TypeText Text:=" "
'Make "Figure x.x." bold (last space not included)
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = False
.Text = "Figure*.*"
.Font.Bold = False
.MatchWildcards = True
.Replacement.Text = "^&"
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceOne, Forward:=True, _
Wrap:=wdFindContinue
End With
End Sub
The replacing bit does not make the recently inserted "Figure x.x." bold, but the next one in the text, even if I specified the search to be backwards. If I type .Execute Replace:=wdReplaceOne, Forward:=False, _, it goes to the end of the document and moves upwards, making everything bold.
In my sample document I have multiple already captioned images, but that wouldn't normally be the case; I would like to format captions as I insert them, instead of reformatting them when the document is finished.
Where is my mistake and why, if you were so kind to explain?
Thank you kindly.
I found my answer: for whatever reason, once fields are involved, finding and replacing does not work that well; i.e. it won't correctly find periods within "1.1.". I tried it with and without wildcards, using ?, * and anything I could think of.
I resorted to another method:
Select whole line
Make bold
Go to the end of the line
Uncheck bold so that the description has normal font width
'Code before this point remains identical
'Make "Figure x.x." bold (last space not included)
'Select from cursor point to beginning of line; make bold
Selection.MoveStart Unit:=wdLine, Count:=-1
Selection.Font.Bold = True
'Move cursor to end of the line; uncheck bold format
Selection.EndKey Unit:=wdLine
Selection.Font.Bold = wdToggle
This way, the cursor is placed right after the caption label, bold not selected. Seems clumsy and highly unprofessional, but works.
Thanks, everyone!
When Word inserts a caption it is basically providing a shortcut for the insertion of a number of fields and their associated switches.
Thus if we insert a Figure caption that references Heading 3 style for the chapter numbers we get something like
Figure 2.1.3-1: Text for the caption
If we highlight the 'Figure 2.1.3-1' in the Word document and press Shift-F9 this will show that the caption numbering is composed of a styleref field and a seq field
Figure {Styleref 3 \w}-{Seq Figure}
When the field codes are shown we can easily use the built in Find/Replace of word to change the text between the field brackets. So we could search for 'Styleref 3' and replace it with 'Styleref "Heading 2"' or in fact 'Styleref "myStyle"'.
If the Word wildcard search is used then you can simultaneously change the style ref to the desired style and apply the bold effect, thus achieving the effect that the OP desires. I'll leave that to a little research by the OP.
This is fine if we have to convert an existing document. If we are inserting Captions as we type then it would be preferable to use a macro to insert the caption numbering that is desired by firing a macro that inserts the appropriate caption numbering/formatting from a set of keystrokes.
The macro below will insert a caption of the type desired, use the defined style for chapter numbering and apply the bold effect to all the numbering upto the separating tab.
Option Explicit
' Any Leading and Trailing spaces in the Const definition strings are deliberate
' Heading 2 is used for ease of demonstration. Heading 2 should be replaced by the style
' from which you wish to take the heading numbers.
Const SpecialCaptionStyle As String = """Heading 2""" ' Name of the style to reference for the heading number
Const CaptionType As String = "Figure " ' The trailing space is required
Const CaptionNUmberingStyle As String = " \w " ' see switches for the styleref field
Const CaptionNumberSeparator As String = "-"
Public Sub InsertSpecialCaption()
' Get the range into which we insert the styleref and seq fields
Dim myFieldRange As Word.Range
Set myFieldRange = Selection.Range
'Preserve the srarting range for later use
Dim myEffectRange As Word.Range
Set myEffectRange = Selection.Range.Duplicate
'Set the style to Caption style.
'Caption style will be applied to any text in the paragraph of the selection point
myFieldRange.Collapse direction:=wdCollapseEnd
myFieldRange.Paragraphs.Item(1).Style = myFieldRange.Document.Styles(wdStyleCaption)
'Insert the label of the caption type. In this case it is the text 'Figure'
myFieldRange.InsertAfter Text:=CaptionType
myFieldRange.Collapse direction:=wdCollapseEnd
Dim myField As Word.Field
' Insert the styleref field to obtain the heading number of the style we specify
Set myField = myFieldRange.Document.Fields.Add(Range:=myFieldRange, Preserveformatting:=False)
myField.Code.Text = "Styleref " & SpecialCaptionStyle & CaptionNUmberingStyle
Set myFieldRange = myField.Result
'Insert the text string used as a seperator between the chapter number and the captiontype number
myFieldRange.InsertAfter Text:=CaptionNumberSeparator
myFieldRange.Collapse direction:=wdCollapseEnd
' Insert the Seq field to get the sequential number of the caption
' in this case we use the same name of the label but it could be different
Set myField = myFieldRange.Document.Fields.Add(Range:=myFieldRange, Type:=wdFieldEmpty, Preserveformatting:=False)
myField.Code.Text = "Seq " & CaptionType
Set myFieldRange = myField.Result
myFieldRange.Collapse direction:=wdCollapseEnd
' Insert the seperator text from the number to the Caption text NB I always use : followed by a tab
myFieldRange.InsertAfter Text:=":" & vbTab
' Adjust the range to omit the tab from formatting
' update the fields
' Apply bold effect to the inserted caption label
myFieldRange.MoveEnd unit:=wdCharacter, Count:=-1
myEffectRange.End = myFieldRange.End
myEffectRange.Fields.Update
myEffectRange.Font.Bold = True
End Sub
All that is required is to link the macro to a suitable key sequence, which is the provenance of the OP.
First though, I'd strongly suggest using F8 to step through the macro to see how the Caption number is inserted.
I'm a very novice programmer (think code-enthusiastic English major) trying to do something that I think should be very straightforward. For work I have to incorporate materials from multiple Word-using sources, all of whom have different settings for various styles. So Alan will have Heading 1 be, for example, 14 pt Arial, while Beth's Heading 1 will be 16 pt Courier New, and the standard for my org for Heading 1 is 18 pt Calibri. The different styles can quickly pile up, and even if you change the imported materials to fit what is correct, there's a bunch of material in there that can cause issues.
What I'd like is to build a VBA macro that runs through the document and essentially says, "this is Body? Cool, all Body text is set to these settings. This is Heading 1? All Headings 1 should be XYZ," and then goes through and does those conversions. I got an O'Reilly book on writing macros for Word, but I quickly got in over my head. Any suggestions on how to start, or where to look?
Thanks in advance.
ETA
My code is now at this point:
Sub test()
Set objDoc = ActiveDocument
' First, highlight the entire document in the default color (i.e. the color to use for styles that aren't defined in our guide)
objDoc.Range.HighlightColorIndex = wdDarkYellow
' Need to figure out how to do color code (RGB) this works for now.
reformatStyle "Heading 1", False, "Calibri", wdBlack, 16
reformatStyle "Body"
' Call reformatStyle once for each style, setting the appropriate values for bold, fontName, color and size.
' valid colors are at https://learn.microsoft.com/en-us/office/vba/api/word.wdcolorindex
End Sub
Sub reformatStyle(style, bold, fontName, color, fontSize)
With objDoc.Content.Find
.ClearFormatting
.style = style
' this first bit selects the blocks that have the specified style
With .Replacement
.Font.bold = bold
.Font.Name = fontName
.Font.ColorIndex = color
.Font.Size = fontSize
.Highlight = False
' this modifies the selected blocks. Note that we remove the highlighting at this point, otherwise it would remain at the default color
End With
.Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceAll
End With
End Sub
What I'd like to do is be able to set the color to RGB values. Any suggestions?
I would like to delete certain lines from my word document using a VBA macro. Basically the (block of) text to be deleted (and replaced by "***") follows a certain pattern (below).
Bottom of Form
perma-link
Top of Form
save
Bottom of Form
[+] ....
[–] ....
Top of Form
"...." represents text that changes every block, but for sure the line starts with "[+]" or "[-]".
Please suggest a suitable macro
EDIT: In the screenshot, I would like to keep the text in yellow and delete the rest. (in the actual file, the text isn't in yellow)
PS-FYI, I tried using the example looping a find and delete row macro (for line by line deletion) but i get a runtime error 5941 with debugging option highlighting the line "selection.row.delete" in the macro.
What does this mean?
Assuming that the example list is a list of paragraphs beginnings the following code should do the trick. What you have to do is to place all 'paragraphs starting' into array arrRemove as I did for the test. If any of the mark is a special marks (see this link for additional information) you need to add \ in front of it as I did for [+] and [-]. Hope this is what you are looking for.
Sub Macro2()
Dim arrRemove As Variant
arrRemove = Array("Bottom of Form", "perma -link", "Top of Form", _
"\[+\]", "\[\-\]", "Donec", "In")
Dim i!
For i = 0 To UBound(arrRemove)
Activedocument.Range(0,0).select
Selection.Find.ClearFormatting
With Selection.Find
.Text = arrRemove(i) & "*^13"
.Replacement.Text = "" 'replace with nothing
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next i
End Sub
The above macro will remove all yellow paragraph in the following document.
I have a document with many acronyms that need to be captured and put into an acronyms table at the end of the document.
The term acronym has various meanings. I'd like to create a table that has all of the words that are initialized; two or more capitalized letters that are short for a longer meaning. I.e., CD-ROM, USB, SYNC, MMR, ASCAP, etc.
How do I create a macro to do this?
Something like this might get you started. Add a reference to "Microsoft VBScript Regular Expressions" (Edit Macro: Tools > References). This library is the file, "vbscript.dll".
You may need to adjust the regexp if all your acronyms aren't only upper-case letters (eg some may contain numbers).
Sub Acronyms()
Dim dict, k, tmp
Dim regEx, Match, Matches
Dim rngRange As Range
Set regEx = New RegExp
Set dict = CreateObject("scripting.dictionary")
regEx.Pattern = "[A-Z]{2,}" '2 or more upper-case letters
regEx.IgnoreCase = False
regEx.Global = True
Set Matches = regEx.Execute(ActiveDocument.Range.Text)
For Each Match In Matches
tmp = Match.Value
If Not dict.Exists(tmp) Then dict.Add tmp, 0
dict(tmp) = dict(tmp) + 1
Next
For Each k In dict.Keys
Debug.Print k, dict(k)
Next k
End Sub
Thanks Tim, your code works great!
If it will be of any use to others, the pattern [A-Z]{1,}([a-z]*|\&|\.*)[A-Z]{1,} will find more acronyms...
(I do not have permission to post comments, hence adding this as answer)
Edit (still no way to add comments): \b[A-Z]{1,}([a-z*]|\&|\.|\-)[A-Z]{1,}\b is more robust, but will fail if the last character of the acronym is not capitalized.
I have found the following works well (where some business name acronyms are tolerable). I use this to test data entries in Access, it should also work for a Word document range.
objRegExp.Pattern = "([A-Z]{1,}((\&(?![A-Z]\s[\w]{3})\w*)+|\.\w*)+)|[A-Z]{2,}(?![A-Z]*\s[A-Z]{1}[a-z])"
J&K =Match
JK&S =Match
J.S.S =Match
JK&S.K =Match
JSK =Match
JK =Match
DKD And Sons =No Match
J&K Engineering =No Match
PKF Rogers and Associates =No Match
I use RegExHero to test my expressions
I used the following to find abbreviations in my PhD thesis. They were all in "()".
regEx.Pattern = "\([A-Z]{1,}([a-z]*|\&|\.|\-*)[A-Z]{1,}\)"
You will be running a macro on the main Word document. Open a separate Word document that is blank. This will be used to store discovered the acronyms.
Press "Record Macro". Choose a unique name, and assign a shortcut key such
as CTRL + ALT + A.
Open the Find dialogue (CTRL + F). Paste the following search text:
<[A-Z]{2,}>. In the Find dialogue, choose "More" > check the box for "Use Wildcards". Click the Find Next button.
Right-click on the selected text, being careful not to change the
highlight. Select Copy from the context menu.
Navigate to the separate Word document (ALT + TAB, select the Word
document). Paste the copied text, and hit Enter. ALT + TAB back to
the original Word document.
Close the find dialogue and click the right arrow once. This moves
the cursor off the highlighted text, and readies it for the next
search.
Stop the macro recording.
You now have a macro that finds a word containing two or more capitalized letters, and saves the text to a separate document. In order to search for the remaining acronyms, press CTRL + ALT + A continuously until the end of the document has been reached. Or, edit the macro, and add while a loop.
Here is what the macro looks like (without the loop):
Sub GetAcronyms()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<[A-Z]{2,}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Selection.Copy
Windows("Document1.docx").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeParagraph
Windows("TheOriginalDocument.docx").Activate
Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub