I am writing a sub that finds specific text by whole word and highlights it. The problem is that the user wants the text in grey (wdGrey25) rather than the default of yellow. Here is my sample code:
Public Sub HighlightStrings()
Dim rng As Range
Set rng = ActiveDocument.Range(Start:=0, End:=0)
With rng.Find
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.Text = "Claimant's name"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
.Text = "date"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
.Text = "he/she"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
.Text = "describe incident"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
.Text = "describe condition(s)"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
.Text = "describe occupational disease"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
End Sub
So far, it works perfectly to find and highlight without throwing alignment and positioning off, as with previous versions, but the highlight color is too painful for our older users to look at. Anyone got a fix for that?
Thanks in advance,
-C§
This is what you are looking for:
Options.DefaultHighlightColorIndex = wdGrey25
You need to set it at the beginning of your code.
Related
I have a transliteration function (from cyrillic to latin). I will use this function in a unviersal subroutine (with text of any lenght). This sub must to copy the source text, transliterate (from cyrillic to latin) and paste it below without any formatting changes and without using selection. The next step is reverse transliteration (again copy and paste below). There must be 3 textes in the final. I kinda know how to realize it, but i don't know what i should use instead of selection.
*
P.S. i tried use For Each word In ActiveDocument.Range.Words but it works bad with reverse transliteration (exactly that. without it, the function works perfectly in debugging)
P.P.S. sorry for mistakes in the text, i'm not a native speaker
Since you haven't posted any actual transliteration code, I'll leave you to add the cyrillic and latin character sets to the code below:
Sub Transliterate()
Application.ScreenUpdating = False
Dim p As Long, i As Long, StrLng1, StrLng2
'Insert the character codes for the cyrillic characters here
StrLng1 = Array(ChrW(&H430), ChrW(&H431), ChrW(&H432))
'Insert the corresponding latin characters here
StrLng2 = Array("a", "b", "c")
With ActiveDocument.Range
Do While .Characters.Last.Previous = vbCr
.Characters.Last.Previous.Delete
Loop
.InsertAfter vbCr
'Duplicate Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "^13"
.Replacement.Text = "^l"
.Execute Replace:=wdReplaceAll
.Font.Bold = True
.Text = "[!^l]#^l"
.Replacement.Text = "^p^&"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Text = "^l^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Execute Replace:=wdReplaceAll
.Text = "[!^13]#^13"
.Replacement.Text = "^&^&^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.Last.Previous.Delete
.Characters.First.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count - 1 To 2 Step -3
With .Paragraphs(p).Range
.Font.Italic = True
'Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.MatchCase = True
.Font.Bold = False
For i = 0 To UBound(StrLng1)
.Text = StrLng1(i)
.Replacement.Text = StrLng2(i)
.Execute Replace:=wdReplaceAll
Next
End With
'Duplicate translated paragraph
.Characters.Last.Next.FormattedText = .FormattedText
End With
Next
.Characters.Last.Previous.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count To 3 Step -3
With .Paragraphs(p).Range
.Font.Underline = wdUnderlineSingle
'Reverse Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.Font.Bold = False
.MatchCase = True
For i = 0 To UBound(StrLng1)
.Text = StrLng2(i)
.Replacement.Text = StrLng1(i)
.Execute Replace:=wdReplaceAll
Next
End With
End With
Next
End With
Application.ScreenUpdating = True
End Sub
I am new to word Macros.
I have a task of highlighting all the bolds, italics, superscripts, subscripts. I have already written the code for it which works as expected but it is too slow even for a 50-page document can this code be improved?
The Code
Application.ScreenUpdating = False
For Each ch In ActiveDocument.Characters
If ch.Font.Superscript = True Or ch.Font.Subscript = True Or ch.Font.Bold = True Or ch.Font.Italic = True Or ch.Font.Name = "Consolas" Or ch.Font.Name = "Courier New" Then
ch.HighlightColorIndex = wdYellow
End If
Next
Application.ScreenUpdating = True
Please let me know if this can be improved.
Thanks
There really is no need to loop through the document one character at a time. You should also learn to make more productive use of the tools already available via the GUI. In a long document, a few manual Find/Replace operations might even be faster than your macro! Try:
Sub Demo()
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdYellow
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Format = True
.Forward = True
.Wrap = wdFindContinue
.Font.Superscript = True
.Execute Replace:=wdReplaceAll
.Font.Subscript = True
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Font.Name = "Consolas"
.Execute Replace:=wdReplaceAll
.Font.Name = "Courier New"
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
in a file MS WORD I wish to select a "/" and make bold all characters till the following ^p. The following code works well only for the first occurrence. In the file I have many occurrences and I am not able to apply this in the whole file. I tried several times with "for...next" and others, unfortuntely without success.
Many thanks for your help! Gianluca
Sub bold_title()
Set myRange = ActiveDocument.Content
Selection.Find.ClearFormatting
With Selection.Find
.Text = "/"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^p"
.Forward = True
.Wrap = wdFindAsk
.Format = False
End With
Selection.Find.Execute
Selection.Font.Bold = True
End Sub
The trick is to "collapse" the Selection- think of it like pressing the right-arrow key - so that the next search starts after the "found" text:
Selection.Collapse wdCollapseEnd
Usually, a Do While...Loop construct is used in order to repeat the Find until the end of the document. You'll find lots and lots of examples if you search here and elsewhere on the Internet.
For this to work successfully, make sure you set Wrap to wdFindStop (and not wdFindContinue as is currently in the code shown).
i am attempting to write a macro that with find/replace a string and than move it to an existing heading. The original text is like this:
1. Heading 1
ID: abcd
1.1 Heading 2
ID: abcd
And it should look like:
1.Heading 1 abcd
1.1 Heading 2 abcd
I am having some problems with the code i tried to write, mostly because i am kinda new, but this is what i created so far:
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Style = "Heading 2"
With Selection.Find
.Text = "abcd"
.Replacement.Text = "abcd^p"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
The text is not so important because i managed to replace with what i want but i don't know how to align it with the Heading style.. Thanks
EDIT: I hope i don't screw up again, sorry big :). So i have raw which is the raw text and i want to process it to look like this final. I already found out, thanks to you how to replace the text, it's just that i stuck in the raw version. Thanks, I kinda own you a beer, or two
LATER EDIT: So i have 5 types of Heading formats, 1. Heading 1, 1.1 Heading 2 etc till 5, and all of them have below them an ID, each with a specific number, but the name is the same, ID ASD_PC_AWP_[XXXX]. I just have to get rid of ID ASD_PC_ and put AWP_[xxxx] at same level of the Heading eg: 1.Heading 1 AWP_[xxxx1] ** , **2. Heading 2 AWP_[xxx2]...
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "ID:*^13"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Rng.End = Rng.Paragraphs.First.Range.End - 1
Rng.InsertAfter Split(Split(.Duplicate.Text, ":")(1), vbCr)(0)
.Text = vbNullString
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
Do a wildcard find for any paragraph marker which is followed by ID:.
.Text = "^13ID:"
.Replacement.Text = ""
You will need to specify the style of the replacement text to the heading style because when you delete the paragraph marker at the end of the Heading paragraph you will also delete the style information for the heading paragraph.
You will need to do this with every style heading followed by the ID: text.
Updated 2018-11-01
The following code should work. I got some hints from Macropods ingeneous code.
Update 2 2018-11-01
Revised to work with a list of styles defined by user at OPs request
Sub ConsolidateHeadingWithID()
Const HEADINGS As String = "Heading 1,Heading 2,Heading 3,Heading 4,Heading 5,Other style,another style"
Dim my_headings As Variant
Dim my_heading As Variant
my_headings = Split(HEADINGS, ",")
For Each my_heading In my_headings
With ActiveDocument.StoryRanges(wdMainTextStory)
With .Find
.ClearFormatting
.format = True
.Text = ""
.Style = my_heading
.MatchWildcards = True
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
If .Duplicate.Next(unit:=wdWord).Text = "ID" Then
.Duplicate.Next(unit:=wdParagraph).Style = my_heading
End If
.Collapse wdCollapseEnd
.MoveStart unit:=wdCharacter, Count:=2
.Find.Execute
Loop
End With
With ActiveDocument.Range.Find
.ClearFormatting
.format = True
.Text = "(^13)(ID:)(*)(AWP_)([0-9]{1,})"
.Style = my_heading
.Replacement.Text = " [\4\5]"
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
Copied below is some RegEx code that I have found on Internet. Certain RegEx related search patterns that begin with .Text and likewise their .Replacement.Text usage could not be properly understood by me. Is there anyone who could explain these bunch of RegEx related lines of code to me for my understanding.
Also advise on the use of .Execute Replace with two variants wdReplaceOne and wdReplaceAll which even though sound self explanatory in Word but in VBA, these also need clarification as far as their used is concerned.
Your help would be much appreciated. Here is the code:
Sub StatementReformat()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
'First Page
.Text = "REPORT*EXTRACT FILE : [A-Z0-9]{1,}^13^12"
.Replacement.Text = ""
.Execute Replace:=wdReplaceOne
'Column Headers (except New First Page)
.Text = "^12*VEND^13*[-]{1,}^13"
.Execute Replace:=wdReplaceAll
'Header Underline on First Page
.Text = "[-]{1,}^13"
.Execute Replace:=wdReplaceAll
'Last Page
.Text = " TOTAL #*^12REPORT*{1,255}PAGE*{1,255}FUND TOTALS*[=]{1,}*^13*^13"
.Execute Replace:=wdReplaceAll
'Unwanted Header Lines - First Page
.Text = "REPORT*CHECK^13"
.Execute Replace:=wdReplaceAll
'Empty Paragraphs
.Text = "[ ]{1,}^13"
.Execute Replace:=wdReplaceAll
'Header Line Wrap - First Page
.Text = "(STATUS)^13"
.Replacement.Text = "\1"
'Record Line Wraps
.Execute Replace:=wdReplaceAll
.Text = "(OUTSTANDING)^13"
.Execute Replace:=wdReplaceAll
.Text = "(CLEARED)^13"
.Replaceme`enter code here`nt.Text = "\1 "
.Execute Replace:=wdReplaceAll
.Text = "(VOIDED)^13"
.Replacement.Text = "\1 "
.Execute Replace:=wdReplaceAll
'Pad Records with Multiple Rows
'Pad Records with Multiple Rows
.Text = "(^13)([ ]{20})([ ]{1,8}[0-9]{1,8}.[0-9]{2})"
.Replacement.Text = "\1\2\2\2\2\2\2\2 \3"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub