I have the following code. My document have all tables, some table have diagrams, some tables have strings. If the table contain a cell that has a string "Black player", it would autofit that table to window fit, but it formats all the tables not just the tables that contain "Black player". Can someone help me please.
EDIT: I updated the code, and almost work. Is there a way to change Selection.Columns.AutoFit to something that can autofit to window not just Autofit? I appreaciate the help
Sub Find_Text_in_table()
Dim tbl As Table
For Each tbl In ActiveDocument.Tables
With Selection.Find
.Text = "Black player"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.Information(wdWithInTable) = True Then
tbl.AutoFitBehavior _
wdAutoFitWindow
End If
Next
End Sub
Sub Find_Text_in_table()
Dim tbl As Table
For Each tbl In ActiveDocument.Tables
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Black player"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Information(wdWithInTable) = True Then
Selection.Columns.AutoFit
End If
Next
End Sub
Change:
Selection.Find.Execute
If Selection.Information(wdWithInTable) = True Then
Selection.Columns.AutoFit
End If
To:
If Selection.Find.Execute And _
Selection.Information(wdWithInTable) = True Then
Selection.Tables(1).AutoFitBehavior wdAutoFitWindow
End If
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
I am using the following code to bold parts of a text string, in this case where the word 'Fish' is in brackets after the word 'Oil':
Sub ReplaceAndFormat16()
Dim sConst1 As String, sReplaceMent As String
Dim rRange As Range, rFormat As Range
sConst1 = "Fish"
sReplaceMent = "Oil (" & sConst1 & ")"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Oil (Fish)"
.Replacement.Text = sReplaceMent
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceOne
If .Found Then
Set rRange = Selection.Range
Set rFormat = ActiveDocument.Range(rRange.Start + 5, rRange.Start + 5 + VBA.Len(sConst1))
rFormat.Font.Bold = True
End If
End With
End Sub
This code works perfectly, but only bolds the first instance, and my documents may have up to four instances of this phrase that need to be formatted bold.
How do I amend the code so it carries on and bolds all instances in the document? I am very new to VBA, so apologies if this seems like a stupid question.
Change the line
.Execute Replace:=wdReplaceOne
to
.execute Replace:=wdReplaceAll
Edit
OK the above was a stupid response. The code below does the right thing
Sub ReplaceAndFormat16()
Const myFindStr As String = "Oil (Fish)"
Dim myFindRange As Word.Range
Set myFindRange = ActiveDocument.StoryRanges(wdMainTextStory)
Do
With myFindRange.Find
.ClearFormatting
.Text = myFindStr
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
With myFindRange
.MoveStartUntil cset:="fF"
.MoveEndUntil cset:="hH", Count:=wdBackward
.Font.Bold = True
.Collapse Direction:=wdCollapseEnd
End With
Else
Exit Sub
End If
End With
Loop
End Sub
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
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