I have a question about a problem i need do solve.
I have a word doc, on which i want to run a search and replace query.
But i dont want to change the actual text, i want to put the changed text
in the clipboard and leave the actual one unchanged.
Sub SearchAndReplace()
' marks all bold words,italic words, underlined
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Font.Italic = True
Selection.Find.Font.Underline = wdUnderlineSingle
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = "[test]^&[/test]"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Cautious:
I guess there are better ways to achieve what you want to do as this is not proper coding. (Also as the clipboard only has a limit of 24 items), but for the sake of making your code works, here is my answer:
To copy the text in the clipboard instead of replacing it, you can just use the .copy method.
If you replace your line:
Selection.Find.Execute Replace:=wdReplaceAll
by
Dim iCount As Long
Selection.Find.Execute
Selection.Copy
Do While Selection.Find.Found = True And iCount < 1000
iCount = iCount + 1
Selection.Find.Execute
Selection.Copy
Loop
it should work.
The code is simply copying the item found after each search.
Selection.Find.Execute searches the next itteration of the search every time it appears in the code.
Once there are no search found anymore (or there are too many searches), the loop will stop.
Related
I wrote the 1st ever macro.(Windows 10, WORD 2019)
I'm trying to find words that start with a capital letter in Standard style and continue to have Italic style.
Unfortunately, if I search a document using too many letters in the query - the macro closes (after checking, for example, 1.5 pages) or resets the WORD program.
If I reduce the number of words searched - the macro starts to run longer and longer.
With, for example, a search for 1 letter (U) instead of 32 (ABCDEFGHIJKLŁMNOPQRSTUVWXYZĆŚŃŻŹ) - it does not crash the program.
I tried to add
Application.ScreenUpdating = False at the beginning and
Application.ScreenUpdating = True at the end of the code but it doesn't help much.
Sub Makro1()
Dim Rng As Range
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.find.ClearFormatting
With Selection.find.Font
.Bold = False
.Italic = False
End With
Selection.find.Replacement.ClearFormatting
With Selection.find
.Text = "U"
'.Text = "([ABCDEFGHI])"
'.Text = "([ABCDEFGHI])"
'.Text = "([JKLŁMNOP])"
'.Text = "([QRSTUVWX])"
'.Text = "([YZĆŚŃŻŹ])"
'.Text = "([ABCDEFGHIJKLŁMNOPQRSTUVWXYZĆŚŃŻŹ])"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=2
Set Rng = Selection.Range
If Rng.Italic = True Then
MsgBox "FIND"
End
If Rng.Italic = False Then
Call Makro1
End If
End If
Call Makro1
End Sub
Thanks but your code didn't work. I change the code to:
If .Words.Last.Characters(2).Font.Italic = True Then
.Characters(1).Font.Italic = True
End If
.find.Execute
but it only worked sometimes. When I enabled the macro on a longer text, the macro would hang, show error 5941 "collection object not exist" and stop on the line:
If .Words.Last.Characters(2).Font.Italic = True Then
I spent a lot of time before I discovered why. It turns out that the macro crashes because sometimes there is a punctuation mark in the text next to a capital letter, e.g. period comma...etc. e.g A. B; C: D., The code would have to be improved to ignore this. I try add .IgnorePunct = True after .MatchCase = True but didn't help and macro still crashes
I try change code:
.Text = "<[A-Z][!.,;:„”#$%-+=[\[/[//[#[?[![#[$[%[*[([)[&[*[{[}]*>"
Macro fix some errors in text, work longer but still somewhere is an unacceptable sign after a character with a capital letter and the macro crashes.
Add more unwanted signs
.Text = "<[A-Z][!.,;:„”#$%-+=[\[/[//[#[?[![#[$[%[*[([)[&[*[{[}[<[>_|` - …]*>"
and still the macro crashes.
After rewriting the code to show live which words it checks, I was able to understand in part why the macro crashes.
Problem is hard space:
1 and the comma after digit
if I use normal space instead of hard space - macro work OK.
If change to N = 5, to N = 5 , also work OK.
Another place with STOP working:
2
3
I don't know what other adjustments to make so that the macro doesn't hang up in these places.
[EDIT]
I don't know too much what I'm doing, but I changed the code to:
Sub m1select()
Application.ScreenUpdating = False
With Selection.find
.Text = "<[A-Za-z0-9][! ^13.^s^t^+^=,;:„”#$%-+=[\[[\][\\[\/[\//[\#[\?[\![\#[\$[\%[\*[\([\)[\&[\*[\{[\}[\<[\>_|` - …-]*>"
.MatchWildcards = True
.Execute Forward:=True, Wrap:=wdFindStop
End With
With ActiveDocument.Content
Do While Selection.find.Found
If Selection.Words.Last.Characters(1).Font.Italic = True Or Selection.Words.Last.Characters(2).Font.Italic = True Then
Selection.Font.Italic = True
End If
Selection.find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
and it works. It now corrects all words with partial Italic font not just capitalized.
Admittedly, it does it slowly because I used "Select" , but that way I can see what character the macro hangs on and add it to the exclusion in after the [!
( as all the time is Application.ScreenUpdating = True)
Doesn't work on expressions with a single U e.g.
U letter (after correction it should be U letter) but I make it myself with another script.
You guided me to the solution.
The problem was calling the macro in a loop using Call.
After adding START: at the beginning (and then the rest of the code) and instead of "Call Macro 1" writing "GoTo START" in two places solved the problem.
you're not finishing your code correctly.
When calling a macro from that macro you're creating a loop which never ends. By calling macro1 all the time, the runtime will terminate the Word Application after too many iterations.
You probably don't need to loop (which is a wired loop you created there) through the selection.
The Find-Object provides everything you need. To write all capital letters which are the first ones in a word to italic, when it's not bold or underlined, you could use this, for example:
Sub m()
With ActiveDocument.Content.Find
.Text = "<[A-Z]"
.Style = "Standard"
.Font.Bold = False
.Font.Underline = False
.MatchWildcards = True
.MatchCase = True
.Replacement.Font.Italic = True
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
End Sub
If you want to set the first capital character of a word to italic, when the secnd character is italic too, you have to loop over all possible words:
Sub m1()
With ActiveDocument.Content
With .Find
.Text = "<[A-Z]*>"
.MatchWildcards = True
.MatchCase = True
.Execute Forward:=True, Wrap:=wdFindStop
End With
Do While .Find.Found
If .Words.Last.Characters(2).Font.Italic = True Then .Font.Italic = True
.Find.Execute
Loop
End With
End Sub
You could specify other letters like you did above if you need/want.
If you need more precise selection criteria, you can search them on the help page:
https://learn.microsoft.com/en/office/vba/api/word.find
Good Luck
I want change a word to superscript in macro.
word 2016.
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "7th of every month."
.Replacement.Text = "7^th of every month."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchAllWordForms = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
when i run the macro instead of making "th" as supercript it just create space between "7" and "h"
Result is like this "The meeting is on 7 h of every month."enter image description here
The following code searches for one or two digits, immediately followed by th and superscripts the th. This makes it more flexible than searching the specific string.
It works with a Range rather than a Selection object which will make it faster. The search type is a "wildcard" search.
Sub SuperScript_th_()
Dim rngFind As Word.Range
Dim searchText As String
Dim found As Boolean
Set rngFind = ActiveDocument.content
searchText = "[0-9]{1;2}th"
'searchText = "7th"
With rngFind.Find
.Text = searchText
.MatchWildcards = True
.wrap = wdFindStop
found = .Execute
Do While found
rngFind.Collapse wdCollapseEnd
rngFind.MoveStart wdCharacter, -2
rngFind.Font.Superscript = True
rngFind.End = ActiveDocument.content.End
found = .Execute
Loop
End With
End Sub
The ^t is the instruction in Word's Find to insert a TAB (like pressing the Tab-key on the keyboard). That's why the code in the quesiton is inserting space between the 7 the h in the Replacement.Text.
While Word's Find/Replace is able to format text as part of the Replacement, the difficulty here is that
Not all the text being found should be formatted
The entire text needs to be retained
It's not possible to tell Find/Replace to find text, then format only part of it. That's why the Find needs to be separate from the formatting action. If the entire found text needed to be formatted, then Find/Replace alone would work.
There are also no commands in Word's Find/Replace to apply formatting as a "code" in the Replacement.Text string.
Why don't simply try like this
With Selection.Find
.Text = "7th of every month."
'.Replacement.Text = "7^th of every month."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchAllWordForms = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
Do While .Execute
ActiveDocument.Range(Selection.Range.Start + 1, Selection.Range.Start + 3).Font.Superscript = True
Loop
End With
Edit: With turning off some word options etc the 8 sec time to process 60 pages and 1240 replacement may be reduced to around 2 seconds. the test code
Sub test2()
Dim Rng As Range, tm As Double
tm = Timer
TurnOnOff False
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "7th of every month."
X = 0
Do While .Execute
ActiveDocument.Range(Selection.Range.Start + 1, Selection.Range.Start + 3).Font.Superscript = True
X = X + 1
Loop
End With
Debug.Print X, Timer - tm
TurnOnOff True
End Sub
Sub TurnOnOff(OnOff As Boolean)
Application.ScreenUpdating = OnOff
With Options
.Pagination = OnOff
.CheckSpellingAsYouType = OnOff
.CheckGrammarAsYouType = OnOff
End With
End Sub
I've looked at many different answers online but have not been able to find a solution that fits my code. This is my first time writing VBA in Word (have some moderate experience in Excel).
I thought this post might be what I need but it doesn't stop the loop at the end of the document for me.
I'm trying to insert a continuous section break before the start of a new section, which I designate as text that is formatted with style Heading 1. I'm totally open to doing this another way and would be grateful for your insights!
Sub InsertSectionBreak()
' Go to start of document
Selection.HomeKey Unit:=wdStory
' Find next section based on header formatting, insert continuous section break just before
'
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 1")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute = True
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.InsertBreak Type:=wdSectionBreakContinuous
Loop
End Sub
The code in the question is not bad, but has a major problem: The Selection is being moved towards the front of the document in order to insert the Section Break. This means that next time Find runs it again finds the same Heading 1 and thus repeatedly inserts Section Breaks in the same place.
The other problem is that the code is executing Find as part of the Do While criterium (which is why it's not finding the first instance of Heading 1 in the document).
The following code sample works with Range objects instead of the Selection. You can think of a Range like an invisible selection with a very important difference: there can be multiple Ranges; there can be only one selection.
The suggested code uses two ranges: one for the Find and the other for inserting the Section Break. The Find range is set to the entire document. Whether the Find is successful is stored in a boolean variable (bFound).
If Find is successful the found range is duplicated to the range for the Section break. Duplicate makes an independent "copy" of the original range so that they can be manipulated independently of one another. The range for the section break is then collapsed to its starting point (think of it like pressing left-arrow), then the section break is inserted.
The Find range, however, is collapsed to its end point in order to move it beyond the text formatted with Heading 1 so that the next Heading 1 can be targeted. Find is then executed again and the loop repeats until no more instances of Heading 1 are found.
Sub InsertSectionBreak()
Dim rngFind As Word.Range, rngSection As Word.Range
Dim bFound As Boolean
Set rngFind = ActiveDocument.content
' Find next section based on header formatting, insert continuous section break just before
'
rngFind.Find.ClearFormatting
rngFind.Find.style = ActiveDocument.styles("Heading 1")
With rngFind.Find
.text = ""
.Replacement.text = ""
.Forward = True
.wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
bFound = .Execute
End With
Do While bFound
Set rngSection = rngFind.Duplicate
rngSection.Collapse wdCollapseStart
rngSection.InsertBreak Type:=wdSectionBreakContinuous
rngFind.Collapse wdCollapseEnd
bFound = rngFind.Find.Execute
Loop
End Sub
If the content you're interested is related to a heading, you can obtain all the content under that heading without the need for Section breaks. For example:
Sub GetHeadingSpanText()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = InputBox("What is the text to find?")
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If .Find.Found = True Then
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
MsgBox Rng.Text
End If
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Note that this approach get's all the content associated with the nearest heading, regardless of its level; a more sophisticated approach can be use to get all the content associated with a particular heading level so that, if the match is found under a sub-heading, the prior major heading is used to determine the range spanned.
I have a Word document with blocks of text marked with styles called "Princple" and "BusinessRule". These blocks of text are scattered throughout the document. I would like to find and copy these blocks to a separate document in the order in which they appear. The code I am using is:
Dim SelStyle As String
'SelStyle = "Principle"
SelStyle = "BusinessRule"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Style = SelStyle
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Copy
Windows("Document1").Activate
Selection.TypeParagraph
Selection.PasteAndFormat (wdFormatPlainText)
Selection.TypeParagraph
Windows("mainDoc.docx").Activate
Selection.MoveRight Unit:=wdCharacter, Count:=1
As you see, this is a manual process: first un-comment the Principle, extract all of those, then comment Princple and uncomment BusinessRule. Not great. Is there any way to search for .Style="Principle" or .Style="BusinessRule" so I get them all in sequence? (And, secondarily, if you have a suggestion for looping through the whole document to do this, I would be additionally grateful. :-))
Thanks - Bill
Why not store the values in an array?
Sub Sample()
Dim SelStyle(1) As String
SelStyle(0) = "Principle"
SelStyle(1) = "BusinessRule"
For i = 0 To 1
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Style = SelStyle(i)
'
'~~> Rest of your code
'
Next i
End Sub
fwiw, I changed my approach on this. Instead of searching for styles, I go through each paragraph in the document and see if the style is "Principle" or "BusinessRule". If true, then I copy/paste the paragraph. So not only do I get the "or", but I also get them in order.
I make a several page word document every week. I copy text from a PDF and paste it into a word document, I then format the text that I pasted.
This takes a long time and i would like to automate it.
I need a macro or some code to select specific text, then make that text bold. The specific text i need to bold is what i call a scrap code.
There are 60 different codes. For example "FIPS", or "LILL".
Something like this:
Sub A()
'
' a Macro
'
'
Dim A(3) As String
A(1) = "code1"
A(2) = "code2"
A(3) = "code3"
For i = 1 To 3
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Font.Bold = True
.Execute FindText:=A(i), ReplaceWith:=A(i), Format:=True, _
Replace:=wdReplaceAll
End With
Next i
End Sub
HTH!
Edit
To switch dollar amounts to bold
Sub a()
'
' a Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Bold = True
With Selection.Find
.Text = "$([0-9.,]{1,})"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
I would suggest recording a macro.
Then do all the modifications and formatting.
Finally, look at the code of the macro and see how it did it.
The one thing you need to figure out is how you logically want to locate the text you want to bold.
Is it a specific line? Is it at the beginning of a known word?
Once you have that answered, you can combine it with the code of the macro and automate the task.