I use the following macro to check documents for US spelling (referencing an installed custom dictionary) and run a ligatures check, replacing any applicable ligatures. It works well but a number of formatting changes show up on the right hand side of the document, including:
Formatted: Font 12 pt
Formatted: Font Not Italic
Field Code Changed
I'm OK with the above things being checked, but I don't want them to be shown in the tracking (only the ligature replacement tracking should be shown).
Could someone help me to adjust the following macro code so that only the replacement of the ligatures shows in the tracking? Many thanks in advance!
Sub USEnglish()
Selection.WholeStory
Dim i As Long, j As Long, k As Long
Dim StrFnd As String, StrRep As String
Dim ArrRep(), oSuggestions, Rng As Range
Application.CheckLanguage = False
Application.ResetIgnoreAll
Options.CheckGrammarAsYouType = True
Options.CheckGrammarWithSpelling = True
Options.ContextualSpeller = True
Options.CheckSpellingAsYouType = True
ArrRep = Array("ff", "fi", "fl", "ffi", "ffl")
With ActiveDocument
.TrackRevisions = True
.Range.LanguageID = wdEnglishUS
.SpellingChecked = False
.GrammarChecked = False
.ShowGrammaticalErrors = True
.ShowSpellingErrors = True
For i = 0 To UBound(ArrRep)
StrFnd = ChrW(&HFB00 + i)
StrRep = ArrRep(i)
For j = 1 To 3
On Error Resume Next
With .StoryRanges(j).Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = StrRep
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Next j
Next i
End With
End Sub
Just turn off formatting tracking and restore it when you've finished.
With ActiveDocument
.TrackFormatting = False
Field Code Changed is likely to be a result of the find and replace.
Related
I have found a code that finds a specific keyword and inserts the relative hyperlink which is specified. But the macro seems to only do one keyword at a time and is unable to do multiple. For example, in the code below it the macro will change the last SearchText to the correct hyperlink. Is there any way it could do multiple I'm looking to do this for website blogging so there would actually be over a 100 Keywords and relative hyperlinks? Any would help would be greatly appreciated.
Private Sub HyperlinkText_Click()
Dim SearchRange As Range
Dim SearchText As String
Dim WebAddress As String
Set SearchRange = ActiveDocument.Range
SearchText = "AMD41"
WebAddress = "http://www.example.com/"
SearchText = "AMD42"
WebAddress = "http://www.examples.com/"
With SearchRange.Find
Do While .Execute(SearchText, , True, , , , True) = True
With SearchRange
.Hyperlinks.Add SearchRange, WebAddress
End With
SearchRange.Collapse wdCollapseEnd
Loop
End With
End Sub
I tried just adding more SearchText and WebAddress and thought it might add multiple hyperlinks to the relative keywords.
Potentially very fast, especially where you have multiple instances of the same expression to convert:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, ArrFnd, ArrRep
ArrFnd = Array("AMD41", "AMD42")
ArrRep = Array("http://www.example.com/", "http://www.examples.com/")
With ActiveDocument
For i = 0 To UBound(ArrFnd)
.Hyperlinks.Add Anchor:=.Range(0, 0), Address:=ArrRep(i), TextToDisplay:=ArrFnd(i)
.Hyperlinks(1).Range.Cut
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Wrap = wdFindContinue
.Text = ArrFnd(i)
.Replacement.Text = "^c"
.Execute Replace:=wdReplaceAll
End With
.UndoClear
Next
End With
Application.ScreenUpdating = True
End Sub
All you need ensure is that you have the same number of entries for ArrFnd and ArrRep.
UPDATE: Following the suggestion of Cindy below, I used the InRange function. My function iterates fine through the Find operation. But the function is failing to return FALSE when the selection is outside the named range. See "FAILING HERE" below. Thanks.
Using Visual Basic, I need to validate whether the selection location in a Word document is within a named range. Many years ago, I used this code to do that:
ActiveDocument.Bookmarks("typdef").Select
While ((WordBasic.CmpBookmarks("\Sel", "typedef") = 8 _
Or WordBasic.CmpBookmarks("\Sel", "typedef") = 6 _
Or WordBasic.CmpBookmarks("\Sel", "typedef") = 10) _
And leaveloop <> 1
...
If WordBasic.CmpBookmarks("\Sel", "\EndOfDoc") = 0 Then
leaveloop = 1
End If
Wend
Here's the updated function I wrote:
Function FormatSpecHeadReturn(strStyle)
Dim rngBookmark As Word.Range
Dim rngSelection As Word.Range
Set rngBookmark = ActiveDocument.Bookmarks("SpecBodyPairRange").Range
Set rngSelection = Selection.Range
var = rngSelection.InRange(rngBookmark)
Debug.Print var
Do While rngSelection.InRange(rngBookmark) = True
Selection.Find.Style = ActiveDocument.Styles(strStyle)
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey
' FAILING HERE: Returns TRUE when selection point
' is outside SpecBodyPairRange
var = rngSelection.InRange(rngBookmark)
Debug.Print var
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.InsertBefore Chr(182)
Selection.EndKey
Selection.InsertAfter vbTab
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
If rngSelection.InRange(rngBookmark) <> True Then Exit Do
Loop
End Function
I was using CmpBookmarks in this current project, but it did not reliably returning the value of the current location. When the selection point is within the named range, it returns 8 for two loops, and then returns 6. When the selection point is outside the named range, CmpBookmarks returns 6.
Obviously, CmpBookmarks is deprecated. I can't find the return values that CmpBookmarks produces, and I can't find a modern equivalent function.
I confess I don't understand the difference between the named "SpecBodyPairRange" range and the range assigned to r, here:
Dim r As Range
I can see that "r" in this instance appears to hold the entire document. I studied Range Interface and Selection Interface on Microsoft.Office.Interop.Word, which I don't yet fully understand. I'm not a programmer, only a semi-technical writer self-taught in some coding who has the task of automating document conversion.
There must be a better way to compare the selection point to validate if it's within a named range, but I can't find it. Any pointers you can give me are sincerely appreciated!
Not a big Word VBA person but can you just compare the Start and End properties?
Dim bm As Bookmark
Set bm = ActiveDocument.Bookmarks("tester")
Debug.Print "Bookmark", bm.Start, bm.End
Debug.Print "Selection", Selection.Start, Selection.End
In order to determine whether one Range is within another use the InRange method:
Dim rngBookmark as Word.Range
Dim rngSelection as Word.Range
Set rngBookmark = ActiveDocument.Bookmarks("typeDef").Range
Set rngSelection = Selection.Range
If rngSelection.InRange(rngBookmark) = True Then
'Do something
End If
You could use VBA's InRange Method. For example:
Function FormatSpecHeadReturn(strStyle)
Dim Rng As Range
With ActiveDocument
Set Rng = .Bookmarks("SpecBodyPairRange").Range
With .Bookmarks("SpecBodyPairRange").Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^p"
.Replacement.Text = ""
.Style = strStyle
.Format = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False
.Execute
End With
Do While .Find.Found
If .InRange(Rng) = False Then Exit Do
.Style = "SpecHead"
.Paragraphs.First.InsertBefore Chr(182)
.InsertAfter vbTab
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
End Function
I have a system that generate test results reports for me. I managed to create the right table templates for the use of this system. But, for some reason the report, which is about 950 pages long full of tables and diagrams, was generated while the tables are sorted in a descending order. I have tried to make the auto reports to output the tables in an ascending order without success.
Then I started to look for a solution to this problem. One of the solution that I have is the following VBA code. But, when I apply it on the whole report it gets stuck and Word turns to "Not Responding". I am completely new to VBA and don't see the reason. Can you please tell me why ?
Attribute VB_Name = "SortTable_Ascend"
Sub Find_Text_in_table()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Step"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Tables(1).SortAscending
End If
Loop
End Sub
By the way, I only look for certain tables (the ones that have a column with the string "Step" in them) and apply the sorting on them. When I took only 100 pages of this document and applied this script it did the job and didn't get stuck.
The following should process a bit faster and will get through all tables.
Sub Find_Text_in_table()
Dim rng As word.Range, tbl As word.Table
ActiveDocument.ActiveWindow.View.Type = word.WdViewType.wdNormalView
Application.Options.Pagination = False
For Each tbl In ActiveDocument.Tables
Set rng = tbl.Range
rng.Find.ClearFormatting
With rng.Find
.Text = "Step"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .found Then
If rng.InRange(tbl.Range) Then
tbl.SortAscending
End If
End If
End With
Next
ActiveDocument.ActiveWindow.View.Type = word.WdViewType.wdPrintView
Application.Options.Pagination = True
End Sub
Here is an alternative that avoids the word find and replace. It also uses the more general Sort method which replicates the dialog box you get when doing the sort in word. This might be helpful if you want to sort on multiple columns.
Option Explicit
Sub test()
SortTables_WithKey "Step"
End Sub
Sub SortTables_WithKey(this_key As String)
Dim myIndex As Long
Dim myLastTable As Long
myLastTable = ActiveDocument.Tables.Count
Application.ScreenUpdating = False
Application.Options.Pagination = False
For myIndex = 1 To myLastTable
' MS have deprecated the use of statusbar so if this line
' but it still appears to work in Word 2016
Application.StatusBar = "Table " & CStr(myIndex) & " of " & CStr(myLastTable)
If InStr(ActiveDocument.Tables(myIndex).Range.text, this_key) > 0 Then
' https://learn.microsoft.com/en-us/office/vba/api/word.table.sort
' Replicates the type of sort when done using Word
ActiveDocument.Tables(myIndex).Sort _
excludeheader:=True, _
fieldnumber:=1, _
sortfieldtype:=wdSortFieldAlphanumeric, _
sortorder:=wdSortOrderAscending
End If
DoEvents
Next
Application.ScreenUpdating = True
Application.Options.Pagination = True
End Sub
Edited to revise the sub to include the recommendations about screen updating, events and pagination (others beat me to it). I've also included code to put a message in the status bar (bottom left corner of the word window) which will show progress (Table x of y). I tested the above on a document I have with 125 tables and (without sorting the tables) it completed in around 5 seconds.
I also corrected one error I made
sortorder:=wdSortAscending
should have been
sortorder:=wdSortOrderAscending
Hence the addition of 'option explicit' at the start of the code.
Try:
Sub SortTables()
Application.ScreenUpdating = False
Dim t As Long, bfit As Boolean
With ActiveDocument
For t = 1 To .Tables.Count
With .Tables(t)
If InStr(1, .Range.Text, "Step", 0) > 0 Then
bfit = .AllowAutoFit
If bfit = True Then .AllowAutoFit = False
.SortAscending
If bfit = True Then .AllowAutoFit = True
End If
End With
If t Mod 100 = 0 Then DoEvents
Next
End With
Application.ScreenUpdating = True
End Sub
Turning off screen updating and the table autofit property will both enhance performance. Running DoEvents periodically on long operations also gives Word some breathing space.
I have the task of finding numeric in a word document and alternatively superscript and subscript them.
I used this:
test = True
Dim chr As Range
For Each chr In ActiveDocument.Range.Characters
If IsNumeric(chr.Text) And test = True Then chr.Font.Subscript = True
test = False
If IsNumeric(chr.Text) And test = False Then chr.Font.Superscript = True
test = True
Next chr
This is only making all the numbers Superscript , not alternating between Super and Sub script
example Text -
" [17] Saied, M.H., Mostafa, M.Z., Abdel-Moneim, T.M., Yousef, H.A.: On Three Phase Six-
Switches Voltage Source Inverter: A 150° Conduction Mode. Member IEEE, Alexandria
Univercity (2006)"
now in tis example the macro would have to make 17 superscript and 150 subscript and 2006 as superscript..
Please someone help me with this
You could use Range.Characters to loop over the characters. Something like
Dim chr As Range
For Each chr In ActiveDocument.Range.Characters
If IsNumeric(chr.Text) Then chr.Font.SubScript = True
Next chr
Then add some booleans that tell you if you have to set it to sub- or superscript
if anyone needs the answer to this .. here is what I did ,
Selection.MoveUp Unit:=wdParagraph, Count:=2000
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
vFindText = Array("\[", "\] ", " \*")
vReplText = Array("", "", "")
With Selection
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchSoundsLike = False
.MatchAllWordForms = False
.MatchWildcards = True
.Format = True
.MatchCase = True
For i = 0 To UBound(vFindText)
.Text = vFindText(i)
.Replacement.Text = vReplText(i)
.Execute Replace:=wdReplaceAll
Next i
.Text = "[0-9]{1,}"
.Replacement.Text = "^&"
.Replacement.Font.Superscript = True
.Execute Replace:=wdReplaceAll, MatchWildcards:=True
End With
End With
MsgBox "Numbers has finshed , calling double1"
Call Numbers1
this will throw all numbers into subscript then it calls Sub Numbers1
Sub Numbers1()
Dim chr As Range
Dim firstChar As Word.Range
Dim test As Integer
test = 0
Dim firstAlphabet As Range
Selection.SetRange Start:=0, End:=100000
Set firstAlphabet = Selection.Range
For i = 2 To 1600
test = test + 2
Set firstChar = Selection.Characters(test)
If IsNumeric(firstChar.Text) Then firstChar.Font.Subscript = True
On Error Resume Next
Next i
End Sub
This will put all the numbers alternatively into subscript and superscript ....
The code can be optimized obviously ,,, at present it takes too long to do the given job ,,, but after searching for a working method all day, this is the only thing that works
hope this will help will Someone who comes finding this :)
I happen to have problems trying to manipulate the below code to my liking.
First off, the code below deletes everything in between the start and end conditions I have stipulated in my program.
I would like to change this, to delete everything besides those stipulated between the start and end words.
Sub SomeSub()
Dim StartWord As String, EndWord As String
Dim Find1stRange As Range, FindEndRange As Range
Dim DelRange As Range, DelStartRange As Range, DelEndRange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Setting up the Ranges
Set Find1stRange = ActiveDocument.Range
Set FindEndRange = ActiveDocument.Range
Set DelRange = ActiveDocument.Range
'Set your Start and End Find words here to cleanup the script
StartWord = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |"
EndWord = "This message has been scanned for malware by Websense. www.websense.com"
'Starting the Find First Word
With Find1stRange.Find
.Text = StartWord
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
Do While .Execute
'If Found then do extra script
If .Found = True Then
'Setting the Found range to the DelStartRange
Set DelStartRange = Find1stRange
'Having these Selections during testing is benificial to test your script
DelStartRange.Select
'Setting the FindEndRange up for the remainder of the document form the end of the StartWord
FindEndRange.Start = DelStartRange.End
FindEndRange.End = ActiveDocument.Content.End
'Having these Selections during testing is benificial to test your script
FindEndRange.Select
'Setting the Find to look for the End Word
With FindEndRange.Find
.Text = EndWord
.Execute
'If Found then do extra script
If .Found = True Then
'Setting the Found range to the DelEndRange
Set DelEndRange = FindEndRange
'Having these Selections during testing is benificial to test your script
DelEndRange.Select
End If
End With
'Selecting the delete range
DelRange.Start = DelStartRange.Start
DelRange.End = DelEndRange.End
'Having these Selections during testing is benificial to test your script
DelRange.Select
'Remove comment to actually delete
DelRange.Delete
End If 'Ending the If Find1stRange .Found = True
Loop 'Ending the Do While .Execute Loop
End With 'Ending the Find1stRange.Find With Statement
End Sub
Hah! That's a new twist There's certainly more than one way to go about it; my inclination would be to work with (at least) three Ranges. Something like this:
Sub FindAndDeleteEverythingElse()
Dim strFind1 As String, strFind2 As String
Dim rngDoc As word.Range, rngFind1 As word.Range
Dim rngFind2 As word.Range
Dim bFound As Boolean
strFind1 = "You"
strFind2 = "directly."
Set rngDoc = ActiveDocument.content
Set rngFind1 = rngDoc.Duplicate
Set rngFind2 = rngDoc.Duplicate
With rngFind1.Find
.Text = strFind1
bFound = .Execute
End With
If bFound Then
With rngFind2.Find
.Text = strFind2
bFound = .Execute
End With
If bFound Then
rngDoc.End = rngFind1.Start
rngDoc.Delete
rngDoc.Start = rngFind2.End
rngDoc.End = ActiveDocument.content.End
rngDoc.Delete
End If
End If
End Sub
The "main" Range is that of the entire document: ActiveDocument.Content. The Range object is a bit different than other objects, if you set one Range to another it becomes that Range, not a copy. So you need the Duplicate method to make a copy of a Range. This lets you use Find independently for the various Ranges.
If the first Find is successful, the second one is executed. If that is also successful then the Document Range's end-point is set to the starting point of the successful Find and the content of the Range deleted. The Document Range is then re-defined to start at the end-point of the second found Range and end at the end of the Document, and deleted.
You will probably have to set more Range.Find properties than I did in this code snippet - I used the absolute minimum to make working with the Ranges clearer.
There maybe another way but till then you can do this.
try to add dummy character after and before your string like this
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |"
.Replacement.Text = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |######"
.Execute Replace:=wdReplaceAll
.Text = "This message has been scanned for malware by Websense. www.websense.com"
.Replacement.Text = "######This message has been scanned for malware by Websense. www.websense.com"
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
Then try to set range between ###### and ######
this is best answer to set range select a range of text from one Word document and copy into another Word document
Please note that in my word 2007 it is not possible to find within hyperlinks. Try to remove all hyperlink or within range before doing replacement.
another best answer for that: How do you remove hyperlinks from a Microsoft Word document?