I'm stuck with this problem for the past two days and I can't find a way to overcome it.
I've a document (400 pages) where I want to replace ALL the uppercase words to SmallCaps AND set the text as "title sentence".
When I register a macro, I found the commands that I need:
Selection.Range.Case = wdTitleSentence
Selection.Font.SmallCaps = wdToggle
The problem is that I can't find a way to apply these commands only to the uppercase words and NOT to the selected text.
You could try using a wildcard search, though you'll need to be careful how you specify it other wise you could change every capital letter in the document to small caps.
Sub ConvertUpperCase()
Dim findRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
'find at least two consecutive capital letters
.Text = "[A-Z]{2,}"
.MatchWildcards = True
Do While .Execute = True
With findRange
.Case = wdTitleSentence
.Font.SmallCaps = True
.Collapse wdCollapseEnd
End With
Loop
End With
End Sub
Related
I'd like to find several strings within Word document and for each string found, I like to print (debug.print for example) the whole row content where the string is found, not the paragraph.
How can I do this? Thanks
Sub FindStrings
Dim StringsArr (1 to 3)
StringsArr = Array("string1","string2","string3")
For i=1 to 3
With
Selection.Find
.ClearFormatting
.Text = Strings(i)
Debug.Print CurrentRow 'here I need help
End With
Next
End Sub
The term Row in Word is used only in the context of a table. I assume the term you mean is Line, as in a line of text.
The Word object model has no concept of "line" (or "page") due to the dynamic layout algorithm: anything the user does, even changing the printer, could change where a line or a page breaks over. Since these things are dynamic, there's no object.
The only context where "line" can be used is in connection with a Selection. For example, it's possible to extend a Selection to the start and/or end of a line. Incorporating this into the code in the question it would look something like:
Sub FindStrings()
Dim StringsArr As Variant
Dim bFound As Boolean
Dim rng As Word.Range
Set rng = ActiveDocument.content
StringsArr = Array("string1", "string2", "string3")
For i = LBound(StringsArr) To UBound(StringsArr)
With rng.Find
.ClearFormatting
.Text = StringsArr(i)
.Wrap = wdFindStop
bFound = .Execute
'extend the selection to the start and end of the current line
Do While bFound
rng.Select
Selection.MoveStart wdLine, -1
Selection.MoveEnd wdLine, 1
Debug.Print Selection.Text
rng.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
Set rng = ActiveDocument.content
Next
End Sub
Notes
Since it's easier to control when having to loop numerous times, a Range object is used as the basic search object, rather than Selection. The found Range is only selected for the purpose of getting the entire line as these "Move" methods for lines only work on a Selection.
Before the loop can continue, the Range (or, if we were working with a selection, the selection) needs to be "collapsed" so that the code does not search and find the same instance of the search term, again. (This is also the reason for Wrap = wdFindStop).
I have the following code that searches for a certain point in a document and creates a search range until the end of the document. Then within that range it removes the paragraph following entirely bold paragraphs (subheadings), ignoring any styles that aren't Normal and aren't in a table. However, it seems to search the entire document (i.e. the beginning as well). How can I make it only search the range (i.e. from where I've positioned the cursor down to the end of the document)?
Dim aPara As Paragraph
Dim oSearchRange As Range
With Selection.Find
.Text = "Dear "
End With
Selection.MoveDown Unit:=wdParagraph, Count:=4
Set oSearchRange = Selection.Range
oSearchRange.End = ActiveDocument.Content.End
oSearchRange.MoveEnd wdParagraph, -1
For Each aPara In oSearchRange.Paragraphs
If aPara.Range.Font.Bold = True And aPara.Range.Next.Style = ActiveDocument.Styles("Normal") And Not aPara.Range.Next.Information(wdWithInTable) Then aPara.Range.Next.Delete
Next aPara
Thanks
I needed to add .Execute after the "Dear " search, thanks to Teamothy (:
This is a follow-up question to my question (How to search/find for multiple format styles in VBA for Word?). This time instead of inserting a text to the beginning of each heading, we want to remove a few characters from the start of each heading after navigating to a heading titled 'Appendix'.
Trying to get rid of the first number along with the following white space or a period for multi-style paragraphs. For example, we would have headings with '4 Appendix A', '5.1 Intro', '10.2.3 Glossary...', which would be renamed to 'Appendix A', '1 Intro', '2.3 Glossary...'.
I removed the Selection.TypeText Text:=" *Test* " Selection.MoveStart wdParagraph, 1 lines after navigating to the Appendix section and replaced Selection.TypeText Text:=" *Test* " in the If found Then statement with the code seen below.
`If found Then
Selection.HomeKey Unit:=wdLine
If IsNumeric(Selection.Characters(2) = True) Then
Selection.Delete Unit:=wdCharacter, Count:=3
Selection.MoveStart wdParagraph, 1
ElseIf IsNumeric(Selection.Characters(1) = True) Then
Selection.Delete Unit:=wdCharacter, Count:=2
Selection.MoveStart wdParagraph, 1
Else
Selection.MoveStart wdParagraph, 1
End If
End If`
Getting run-time error '5941' - The requested member of the collection does not exist. If IsNumeric(Selection.Characters(2) = True) Then seems to be the cause of the error. If I change the '2' to a '1' and Count:=3 to Count:=2 in the If statement and '1' to a '2' and Count:=2 to Count:=3 in theElseIf, then the code is executable. This is a problem because it doesn't recognize theElseIf` and only deletes 2 characters for a double-digit number leaving an unwanted white-space or period, i.e., '.2.3 Glossary...' or ' Appendix G'.
The reason for the error 5941 due to Characters(2). This is not doing what you imagine. That gets the second character, only, from the selection, not two characters. And the selection is a blinking insertion point so does not contain two characters. The error says: You're telling me to get the second character, but there aren't two characters, so I can't give you what you require.
Another problem in that line (that you're not seeing, yet): The parenthesis should be before the =, not after the True: If IsNumeric(Selection.Characters(2)) = True.
Since it's necessary to test multiple characters, the selection (or Range) needs to be extended. Word VBA offers a number of "Move" methods; the equivalent to holding Shift and pressing right-arrow on the keyboard is MoveEnd, and there are variations of this such as MoveEndWhile and MoveEndUntil that allow you to specify conditions. Optionally, these can return the number of characters that were moved (as done in the code below).
The following approach uses MoveEndWhile to first get numeric characters (until the next is no longer numeric): MoveEndWhile("0123456789", wdForward)... Followed by extending until the next character is no longer a ..
This Range is then deleted. (There's also a Debug.Print line in there to print out the content of the Range and the number of characters moved, in case that information interests you - just remove the comment mark ').
Note that I've included the entire code, in case others are interested in seeing it in its entirety. The parts from the previous question that are no longer relevant have been removed. You'll find the new part marked as '''NEW CODE HERE.
Sub AppendixFix()
' Declaring variables
Dim multiStyles As String, i As Integer
Dim aStyleList As Variant
Dim counter As Long, s As String, found As Boolean
Dim rngStart As Range
multiStyles = "Heading 1,Heading 2,Heading 3,Heading 4,Heading 5,Heading 6,Heading 7,Heading 8,Heading 9"
aStyleList = Split(multiStyles, ",")
' Start at the top of document and clear find formatting
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
' Navigate to Appendix section
Selection.Find.style = ActiveDocument.styles("Heading 1")
With Selection.Find
.Text = "Appendix"
.Forward = True
.wrap = wdFindStop
.Format = True
.Execute
End With
Selection.HomeKey Unit:=wdLine
Set rngStart = Selection.Range.Duplicate
' Loop through all the styles in the list
For counter = LBound(aStyleList) To UBound(aStyleList)
'Loop as long as the style is found
Do
s = aStyleList(counter)
With Selection.Find
.style = ActiveDocument.styles(s)
.Text = "^p"
.Forward = True
.wrap = wdFindStop
.Format = True
found = .Execute
End With
'''NEW CODE HERE
Dim rngStartOfLine As Range
Dim charsMovedNumeric As Long, charsMovedDot
If found Then
Selection.HomeKey Unit:=wdLine
Set rngStartOfLine = Selection.Range
charsMovedNumeric = rngStartOfLine.MoveEndWhile("0123456789", wdForward)
charsMovedDot = rngStartOfLine.MoveEndWhile(".")
'Debug.Print rngStartOfLine, charsMovedNumeric, charsMovedDot
rngStartOfLine.Delete
Selection.MoveStart wdParagraph, 1
End If
'''END OF NEW CODE
If Selection.Start = ActiveDocument.content.End - 1 Then
'End of Document, then loop to next style in list
Exit For
End If
Loop Until found = False
'start back at the Appendix for the next style
rngStart.Select
Next
End Sub
My goal is to create a TOC with two SEQIdentifiers in it.
It is described and answered HERE, though the given answer is manually configured, and I want to activate it with a macro.
Brief description
I have a sequential Figures throughout the document which can be gathered with Table of figures {SEQ \c "Figure"}.
The Figure structure is as follows:
Figure {STYLEREF 1 \s}-{SEQ Figure \*Arabic \s 1} - Result with 'Figure 1-1' for example.
The client request is to add "Point Figure", meaning between two figures: Figure 1-1 and Figure 1-2 the client can add Figure 1-1.A, Figure 1-1.B and so on.
Here is how I've initially created the sturcture:
Figure {STYLEREF 1 \s}-{SEQ Figure \*Arabic \c}.{SEQ PointFigure \* Alphabetic \s 1}.
The problem now is that I can not include both of them in a single Table of Figures.
Trying to implement the given answer:
So, my next approach was starting to implement the answer given in the link above.
The given answer by the way is as follow:
Bookmark the seq field with a special name - in the example it's tablea
refer to the reference by { SEQ Table \r { REF tablea } }
Here is my code followed by explanation and my problem:
Sub createPointFigure()
Dim rng As Range
Dim fld As Field
Dim searchText As String
Set rng = Selection.Range
rng.InsertAfter "Figure "
rng.Collapse wdCollapseEnd
Set fld = rng.Fields.Add(rng, wdFieldEmpty, "StyleRef 1 \s", False)
Set rng = fld.result
'Move focus after the inserted field
rng.Collapse wdCollapseEnd
rng.MoveStart wdCharacter, 1
rng.InsertAfter "-"
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, wdFieldEmpty, "SEQ Figure \c", False
' select the entire inserted text
Selection.MoveRight wdWord, 4, wdExtend
searchText = Selection.Text
Set rng = Selection.Range
' Search for the specific figure in text
Selection.Collapse wdCollapseStart
Dim found As Boolean
found = False
While Not found And Selection.Start <> 1
findText searchText, False
For Each fld In Selection.Fields
If fld.Type = wdFieldSequence Then
' look for the original seq field
If InStr(1, fld.Code.Text, "\s 1", vbTextCompare) Then
found = True
Exit For
End If
End If
Next fld
If found Then
ActiveDocument.Bookmarks.Add Selection.Text, Selection
Else
' Collapse to the beginning and keep looking for the next one
Selection.Collapse wdCollapseStart
End If
Wend
End Sub
The findText method:
Sub findText(searchParam As String, forwardDirection)
With Selection.find
.ClearFormatting
.Text = searchParam
.Forward = forwardDirection
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Explanation:
Temporary create the closest Figure text
Search backward until finding the appropriate figure (keep looking if found a sequence field with \c).
Once found, create a new bookmark with the name
Construct the field as the answer suggests (Not implemented in the code)
Problems
Testing fails in the insert bookmark line:
ActiveDocument.Bookmarks.Add Selection.Text, Selection
Apparently, Bookmark cannot contain numbers and symbols in it.
How can I distinguish a reusable bookmark? For the next time I'll Create this Figure structure, I would like to reuse the same Bookmark.
All this work has huge overhead. Is there a simpler solution to accomplish my goal?
Thanks.
Thanks to #CindyMeister guidance, here is an elegant answer for my problem.
Point Figure configuration:
Figure {STYLEREF 1 \s}-{SEQ Figure \c}.{SEQ PointFigure \* Alphabetic \s 1}. Figure Text *Style Separator* {TC "{STYLEREF "Figure Title"}" \f F}
Table of Figures Configuration:
{TOC \f F \c "Figure"}
Remarks:
Figure style in my example is configured as "Figure Title"
The {TC} must be of a different style in order for STYLEREF to work.
For that I've used Style Separator (Ctrl + Alt + Return). Character style is another option I think.
All {} brackets in the code examples are Word Fields (Ctrl + F9)
I inserted the Point Figure text as an AutoText, which is added via Macro.
In order to achieve unique point numbering for each 'Figure 1-1' text, I've added a reset field before each one: {SEQ PointFigure \h \r 0}
I'm trying to find all instances of key words in a MS Word document and change their style. The key words are stored within an array and I want to change the style of the particular word only. Ideally this would happen as I type but that is not crucial.
Attempt 1 - Based on recording a macro and changing the search term
Sub Woohoo()
Dim mykeywords
mykeywords= Array("word1","word2","word3")
For myword= LBound(mykeywords) To UBound(mykeywords)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("NewStyle")
With Selection.Find
.Text = mykeywords(myword)
.Replacement.Text = mykeywords(myword)
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
End Sub
This changes the style of the entire paragraph where the words are in.
Attempt 2 - Based on this question here How can I replace a Microsoft Word character style within a range/selection in VBA?:
Sub FnR2()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1","word2","word3")
For nKey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If IsInArray(rng, mykeywords(nKey)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next
Next
End Sub
This finds words that are in single lines but skips the words that are within a paragraph for some reason, e.g. it finds
Some text
word1
more text
but not
Some text before word1 means that the code above doesn't change the format
Word1 also isn't changed in this instance
Attempt 3 - AutoCorrect; not actually tried:
As an alternative I was thinking to use AutoCorrect. However I have more than 100 keywords and have no idea how to add this to the AutoCorrect list automatically (I'm fairly VBA illiterate). The other problem I would see with this approach is that I believe that AutoCorrect is global, whereas I need this only to work for a specific document.
I believe the reason why your macro isn't finding the words is due to the presence of leading or trailing blank spaces. Providing that you have already defined the style "NewStyle" changing your if statement in SubFnR2 from
If IsInArray(rng, mykeywords(nKey)) Then
to
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Should solve the issue. By the way if you want to keep the style of the word depending on whether it is upper or lower case then remove the LCase part.
Edit:
I have included the sub with the modification below. I have tested it on the examples you gave (cut and pasted into word) and it changed the style for both instances word1.
Sub FnR3()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub
Ok, your document behaves has you described, I'm not quite sure why. I checked selecting the range and just the word was selected, but then the whole paragraph was formatted. I have modified the code to modify the selection, shown below. This did just change the word.
Sub FnR4()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
Selection.Collapse
rng.Select
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Selection.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub