I have been working on a code that finds and replaces words to make them italics. However, I cannot figure out how to make this more efficient using an array.
Currently my code is this were I just keep copying and pasting the with loop:
Sub ItalicsText()
'
' ItalicsText Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Italic = True
With Selection.Find
.Text = "Lord of the Rings"
.Replacement.Text = "Lord of the Rings"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.EscapeKey
End Sub
However, I would like to make it so that I could have an array like:
vFindText = Array("Lord of the Rings", "blah", "blah")
I want to do this because I have hundreds of phrases to check and want to make it faster for me to code.
Untested:
Sub AllTexts()
Dim vFindText, v
vFindText = Array("Lord of the Rings", "blah", "blah")
For Each v in vFindText
ItalicsText v
Next v
End Sub
Sub ItalicsText(findWhat)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Italic = True
With Selection.Find
.Text = findWhat
.Replacement.Text = findWhat
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.EscapeKey
End Sub
Related
I use the following code in order to remove formatting. Somehow it does not work.
Sub rep_test()
Dim TempS As String
TempS = Replace_chars("]", "]")
End Sub
Function Replace_chars(search_txt As String, replace_txt As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = search_txt
.Replacement.Text = replace_txt
.Replacement.Font.Bold = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll, Format:=False
End Function
TextSample:
Aaa [BBB] CC [DDD]
Any idea why?
Try:
Sub rep_test()
Call Replace_chars("]")
End Sub
Sub Replace_chars(search_txt As String)
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = search_txt
.Replacement.Text = "^&"
.Font.Bold = True
.Replacement.Font.Bold = False
.Format = True
.Forward = True
.MatchWildcards = False
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
If you want to remove formatting the correct way to do it is to apply the character style "Default Paragraph Font". This will reset the formatting to match the underlying paragraph style. It also has the advantage that you don't need to know what formatting needs to be removed/applied.
Sub FindAndResetFormatting(search_txt As String)
With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = search_txt
.Replacement.Style = ActiveDocument.Styles(wdStyleDefaultParagraphFont)
.Forward = True
.Wrap = wdFindStop
.Format = True
.Execute Replace:=wdReplaceAll
End With
End Sub
So I'm a total newbie when it comes to using VB. I am trying to highlight a word when it is not followed by another specific word within the next two words. I tried the following code but it seems to just the first word. Many thanks in advance.
Sub fek()
'
'
'
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "n."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found = True Then
With Selection.Range
.MoveStart wdWord, 2
End With
With Selection.Find
.Text = "fek"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End If
If Selection.Find.Found = False Then
Selection.Range.HighlightColorIndex = wdYellow
End If
End Sub
The code below should do what you want. You need to bear in mind that what Word defines as a Word can be different to what a human would, e.g. an IP address is counted as 7 words!
Sub fek()
Dim findRange As Range
Dim nextWords As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
.Text = "n."
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute = True
'findRange is now the range of the match so set nextWords to the 2 next words
Set nextWords = findRange.Next(wdWord)
nextWords.MoveEnd wdWord, 3
'look for the specific text in the next two words
If InStr(nextWords.Text, "fek") = 0 Then findRange.HighlightColorIndex = wdYellow
'collapse and move findRange to the end of the match
findRange.Collapse wdCollapseEnd
findRange.Move wdWord, 4
Loop
End With
End Sub
The following would probably be significantly faster if there are many 'n.' strings in the document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
i = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
With ActiveDocument.Range
With .Find
.Forward = True
.Format = False
.MatchCase = False
.Wrap = wdFindContinue
.MatchWildcards = True
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Text = "n."
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = False
.Text = "n.[^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]#[!^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]<[!^s ]#>[^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]<[!^s ]#>[^s ]#[!^s ]#fek"
.Execute Replace:=wdReplaceAll
End With
End With
Options.DefaultHighlightColorIndex = i
Application.ScreenUpdating = True
End Sub
Is there a better way to take a list of addresses on word and separate them down to single line.
I have about 200 addresses to work through and they have to go from this
To this
So it can end up being copied like this into excel
The code I am currently Using is as follows but all that does is uses the replace function to change special formatting characters.
It isn't the cleanest method and if for instance some hasnt used a paragragh break but just a new line then it won't work.
Sub AddressMacro()
'
' AddressMacro Macro
'
'
ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _
ShowAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^l"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^i"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _
ShowAll
End Sub
How about: (replaces)
'1) Chr$(9) to Chr$(32)
'2) Chr$(10) to Chr$(13)
'3) Chr$(11) to Chr$(13)
'4) Chr$(13) & Chr$(13) to Chr$(13)
'5) repeat 4 until there are none
'6) Chr$(13) to Chr$(9)
'7) Chr$(133) to Chr$(13)
EDIT: Here's what I had in mind: (It's a lot -- there's a bottomless pit of information on Word VBA -- http://word.mvps.org/faqs/MacrosVBA/index.htm -- good luck.)
Option Explicit
Sub main()
Call doReplace(Chr$(9), Chr$(32))
Call doReplace(Chr$(10), Chr$(13))
Call doReplace(Chr$(11), Chr$(13))
Do While doReplace(Chr$(13) & Chr$(13), Chr$(13))
Loop
Call doReplace(Chr$(13), Chr$(9))
Call doReplace(Chr$(133), Chr$(13))
End Sub
Function doReplace(OldText$, NewText$) As Boolean
With ThisDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = OldText
.Replacement.Text = NewText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
doReplace = .Execute(Replace:=wdReplaceAll)
End With
End Function
The following code works, but it performs everything on the entire document. I'd like to highlight a block of text, then when I run the macro only have it work on the highlighted text. How do I do that? Thanks...
Sub DoCodeNumberStyle(numchars As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "(^13)([0-9]{" + numchars + "}) "
.Replacement.Text = "\1###\2$$$ "
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("CodeNumber")
With Selection.Find
.Text = "###([0-9]{" + numchars + "})$$$"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub CodeNumberStyle()
DoCodeNumberStyle ("1")
DoCodeNumberStyle ("2")
End Sub
PostScript:
One additional thing I've discovered: if you do more than one find on a Selection, the first find loses/changes the Selection, so the others are no longer bounded by the original Selection (and a wdReplaceAll will continue to the end of the document). To fix this, capture the Selection into a Range. Here's the final version of my method, which now does everything I need, is restricted to the original highlighted selection (even with 3 find-and-replacements), and has also been minimized, code-wise:
Sub AAACodeNumberStyleHighlightedSelection()
With Selection.Range.Find
.ClearFormatting
.Style = ActiveDocument.Styles("Code")
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
' First line:
.Text = "1 //"
.Replacement.Text = "###1$$$ //"
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
' Rest of lines:
.Text = "(^13)([0-9]{1,2}) "
.Replacement.Text = "\1###\2$$$ "
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
' Now style the line numbers:
.Text = "###([0-9]{1,2})$$$"
.Replacement.Text = "\1"
.Replacement.Style = ActiveDocument.Styles("CodeNumber")
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End Sub
Change .Wrap to wdFindStop and this should work for you. I think this might be a minor Word bug; the documentation says that the Wrap value
sets what happens if the search begins at a point other than the beginning of the document and the end of the document is reached (or vice versa if Forward is set to False) or if the search text isn't found in the specified selection or range.
But it seems like it forces the Find to go to the end of the document rather than taking the selection into account. Anyway, there's no need for wdFindAsk if you only plan to run this on selections.
I, too, found that even when beginning a FIND loop on a range, the range is redefined by FIND, and so continuous loop on .execute goes beyond the original range to the end of the document. wdFindStop stops only at the end of the document, not at the end of the original range.
So, I inserted an IF statement:
do while .find.found
...
If .find.parent.InRange(doc.Bookmarks("BODY").Range) = False Then Exit Do
...
.execute
loop
Set myRange = Selection.Range
myRange.Select
With Selection.Find
.Text = "Apple"
.Replacement.Text = "Banana"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
'.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
myRange.Select
With Selection.Find
.Text = "red"
.Replacement.Text = "yellow"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
'.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
My intent is to create a very basic macro to find a series of words and highlight them. Unfortunately, I do not know how to do multiple words in one step. For example, the following code works:
Sub Macro1()
'
' Macro1 Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "MJ:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
However, if I add in another .Text = line, then the MJ: is ignored. Any ideas?
If you are only looking for a few words simply doing multiple find and replaces within the same macro will accomplish what you want. For example, the following will highlight in yellow all occurrences of "target1" and "target2"
Sub HighlightTargets()
' --------CODE TO HIGHLIGHT TARGET 1-------------------
Options.DefaultHighlightColorIndex = wdYellow
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "target1"
.Replacement.Text = "target1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' --------CODE TO HIGHLIGHT TARGET 1-------------------
Options.DefaultHighlightColorIndex = wdYellow
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "target2"
.Replacement.Text = "target2"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Alternatively the following code will let you add all the terms to highlight in one line which may be easier to work with.
Sub HighlightTargets2()
Dim range As range
Dim i As Long
Dim TargetList
TargetList = Array("target1", "target2", "target3") ' put list of terms to find here
For i = 0 To UBound(TargetList)
Set range = ActiveDocument.range
With range.Find
.Text = TargetList(i)
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute(Forward:=True) = True
range.HighlightColorIndex = wdYellow
Loop
End With
Next
End Sub
I had done the following modification. Perhaps not as elegant as the array. But I was thinking along the lines of a user simply pasting a list of values into a field.
Sub HighlightKeyword(SearchWord As String)
'
' HighlightKeyword Macro
'
Options.DefaultHighlightColorIndex = wdYellow
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = SearchWord
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub HighlightKeywordList()
'
' HighlightKeywordList
'
'
Dim HighlightList As String
Dim WordList As Variant
HighlightList = "Lorem Ipsum,amit,Finibus,Bonorum,et Malorum,Vestibulum,Vivamus,Integer"
WordList = Split(HighlightList, ",")
For i = 0 To UBound(WordList)
HighlightKeyword (WordList(i))
Next i
End Sub