In Word it's easy to use vba to apply a highlight to more than one string, word, sentence etc after the user of the document has Ctrl-selected a bunch of them.
However, when I Ctrl-select a few words and run the following statement, only the last of my selected words is changed.
Is there a way to apply wdtitleword to more than one selected word?
Thanks.
sub a()
Selection.Range.Case = wdTitleWord
end sub
Please try this:
Sub changeNonContigCase()
' Find the non-contig selection
If Selection.Font.Shading.BackgroundPatternColor = wdColorAutomatic Then
Selection.Font.Shading.BackgroundPatternColor = whtcolor
End If
' Find and process each range with .Font.Shading.BackgroundPatternColor = WhtColor
ActiveDocument.Range.Select
Selection.Collapse wdCollapseStart
With Selection.Find
.Font.Shading.BackgroundPatternColor = whtcolor
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
' Do what you need
Selection.Range.Case = wdTitleWord
' Reset shading as you go
Selection.Font.Shading.BackgroundPatternColor = wdColorAutomatic
' Setup to find the next selection
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub
This works, but is indirect. I don't think there is a more direct way to achieve this. You can modify to avoid resetting existing formatting that you need to preserve. Until now I didn't even know that it was possible to select a non-contiguous range in MS Word, pity it is not easier to work with in VBA.
Related
I'm facing a challenging request I need to solve using a VBA Macro in Word.
The document is a template that will grab some data in a DB upon generation. It contains multiple tables but I don't know how many and how many data will be in each table.
It looks like this:
Sample initial state
The requirement is to be able to detect the strings that are not followed by a table and delete them.
Said differently when a string is followed by the table, it's all good. When a string is followed by another string, it should be deleted.
The different strings are known, I'm guessing this would help.
After the macro run, my previous sample should look like this:
Sample expected result
I know it looks bit harsh but I don't even know where to start :(
I've looked at macro searching for a text but I wasn't able to find something like
IF stringA is followed by a table then do nothing if not then delete.
Any help of the community would be very much appreciated!
Thanks
Julien
This should get you started:
Sub FindAndDelete()
Dim rng As Range
Set rng = ActiveDocument.Content
With rng
With .Find
.ClearFormatting
.Text = "Text to find"
End With
Do While .Find.Execute
If .Next(wdParagraph).Tables.Count = 0 Then
.Next(wdParagraph).Delete
End If
Loop
End With
End Sub
Thank you so much!
I was able to make it work by slightly modifying it as the proposed code was deleting the string followed by the table:
Dim rng As Range
Set rng = ActiveDocument.Content
With rng
With .Find
.ClearFormatting
.Text = "This is my table C"
End With
Do While .Find.Execute
If .Next(wdParagraph).Tables.Count = 0 Then
.Delete
End If
Loop
End With
my last step is to make the macro run only for a specific part of the document. I guess I need to work on the range. I'll give a try and post the result here.
Again thank you for helping pure newbies!
So I had it working using the below code. I slightly modify the "while" loop so that it deletes the entire row rahter than just the word
Sub HeaderDelete()
'
' HeaderDelete Macro
'
Dim rng As Range
Set rng = ActiveDocument.Content
With rng
With .Find
.ClearFormatting
.Text = "This is my table A"
End With
Do While .Find.Execute
If .Next(wdParagraph).Tables.Count = 0 Then
Selection.HomeKey wdLine
Selection.EndKey wdLine, wdExtend
Selection.Delete
End If
Loop
With .Find
.ClearFormatting
.Text = "This is my table B"
End With
Do While .Find.Execute
If .Next(wdParagraph).Tables.Count = 0 Then
Selection.HomeKey wdLine
SelectionS.EndKey wdLine, wdExtend
Selection.Delete
End If
Loop
With .Find
.ClearFormatting
.Text = "This is my table C"
End With
Do While .Find.Execute
If .Next(wdParagraph).Tables.Count = 0 Then
Selection.HomeKey wdLine
SelectionS.EndKey wdLine, wdExtend
Selection.Delete
End If
Loop
End With
End Sub
The challenge is I have 50+ "this is my table X" and they may possibly change overtime...
I tried to find a solution which wouldn't be used on the ".Find" but more on "if there is a row not followed by a table then delete" but I wasn't successful so far.
On a side note I wanted to remove the table borders of all my tables and I found the below which works great!
Dim doc As Document
Dim tbl As Table
Set doc = ActiveDocument
For Each tbl In doc.Tables
With tbl.Borders
.InsideLineStyle = wdLineStyleNone
.OutsideLineStyle = wdLineStyleNone
End With
Next
Again, thanks a lot for helping VBA newbies!
I'm stuck with this problem for the past two days and I can't find a way to overcome it.
I've a document (400 pages) where I want to replace ALL the uppercase words to SmallCaps AND set the text as "title sentence".
When I register a macro, I found the commands that I need:
Selection.Range.Case = wdTitleSentence
Selection.Font.SmallCaps = wdToggle
The problem is that I can't find a way to apply these commands only to the uppercase words and NOT to the selected text.
You could try using a wildcard search, though you'll need to be careful how you specify it other wise you could change every capital letter in the document to small caps.
Sub ConvertUpperCase()
Dim findRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
'find at least two consecutive capital letters
.Text = "[A-Z]{2,}"
.MatchWildcards = True
Do While .Execute = True
With findRange
.Case = wdTitleSentence
.Font.SmallCaps = True
.Collapse wdCollapseEnd
End With
Loop
End With
End Sub
My goal is to create a TOC with two SEQIdentifiers in it.
It is described and answered HERE, though the given answer is manually configured, and I want to activate it with a macro.
Brief description
I have a sequential Figures throughout the document which can be gathered with Table of figures {SEQ \c "Figure"}.
The Figure structure is as follows:
Figure {STYLEREF 1 \s}-{SEQ Figure \*Arabic \s 1} - Result with 'Figure 1-1' for example.
The client request is to add "Point Figure", meaning between two figures: Figure 1-1 and Figure 1-2 the client can add Figure 1-1.A, Figure 1-1.B and so on.
Here is how I've initially created the sturcture:
Figure {STYLEREF 1 \s}-{SEQ Figure \*Arabic \c}.{SEQ PointFigure \* Alphabetic \s 1}.
The problem now is that I can not include both of them in a single Table of Figures.
Trying to implement the given answer:
So, my next approach was starting to implement the answer given in the link above.
The given answer by the way is as follow:
Bookmark the seq field with a special name - in the example it's tablea
refer to the reference by { SEQ Table \r { REF tablea } }
Here is my code followed by explanation and my problem:
Sub createPointFigure()
Dim rng As Range
Dim fld As Field
Dim searchText As String
Set rng = Selection.Range
rng.InsertAfter "Figure "
rng.Collapse wdCollapseEnd
Set fld = rng.Fields.Add(rng, wdFieldEmpty, "StyleRef 1 \s", False)
Set rng = fld.result
'Move focus after the inserted field
rng.Collapse wdCollapseEnd
rng.MoveStart wdCharacter, 1
rng.InsertAfter "-"
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, wdFieldEmpty, "SEQ Figure \c", False
' select the entire inserted text
Selection.MoveRight wdWord, 4, wdExtend
searchText = Selection.Text
Set rng = Selection.Range
' Search for the specific figure in text
Selection.Collapse wdCollapseStart
Dim found As Boolean
found = False
While Not found And Selection.Start <> 1
findText searchText, False
For Each fld In Selection.Fields
If fld.Type = wdFieldSequence Then
' look for the original seq field
If InStr(1, fld.Code.Text, "\s 1", vbTextCompare) Then
found = True
Exit For
End If
End If
Next fld
If found Then
ActiveDocument.Bookmarks.Add Selection.Text, Selection
Else
' Collapse to the beginning and keep looking for the next one
Selection.Collapse wdCollapseStart
End If
Wend
End Sub
The findText method:
Sub findText(searchParam As String, forwardDirection)
With Selection.find
.ClearFormatting
.Text = searchParam
.Forward = forwardDirection
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Explanation:
Temporary create the closest Figure text
Search backward until finding the appropriate figure (keep looking if found a sequence field with \c).
Once found, create a new bookmark with the name
Construct the field as the answer suggests (Not implemented in the code)
Problems
Testing fails in the insert bookmark line:
ActiveDocument.Bookmarks.Add Selection.Text, Selection
Apparently, Bookmark cannot contain numbers and symbols in it.
How can I distinguish a reusable bookmark? For the next time I'll Create this Figure structure, I would like to reuse the same Bookmark.
All this work has huge overhead. Is there a simpler solution to accomplish my goal?
Thanks.
Thanks to #CindyMeister guidance, here is an elegant answer for my problem.
Point Figure configuration:
Figure {STYLEREF 1 \s}-{SEQ Figure \c}.{SEQ PointFigure \* Alphabetic \s 1}. Figure Text *Style Separator* {TC "{STYLEREF "Figure Title"}" \f F}
Table of Figures Configuration:
{TOC \f F \c "Figure"}
Remarks:
Figure style in my example is configured as "Figure Title"
The {TC} must be of a different style in order for STYLEREF to work.
For that I've used Style Separator (Ctrl + Alt + Return). Character style is another option I think.
All {} brackets in the code examples are Word Fields (Ctrl + F9)
I inserted the Point Figure text as an AutoText, which is added via Macro.
In order to achieve unique point numbering for each 'Figure 1-1' text, I've added a reset field before each one: {SEQ PointFigure \h \r 0}
I'm working on a Powerpoint slide, where I few texts are listed. I have to search for these texts in a Word Document which has a lot of Headings and Texts. After I find the title text, I need to copy the text under the Heading and paste in a new document.
Basically, the VBA coding has to be done in the Powerpoint VBA, with two documents in the background for searching text and pasting it in another.
I've opened the word doc. But searching the text in it and selecting it for copying to another document is what I've not been able to do. Kindly help me.
I see. The following is not exactly elegant since it uses Selection which I always try to avoid but it is the only way I know to achieve such a thing.
Disclaimer 1: this is made in Word VBA, so you will need a slight adaption, like set a reference to Word, use a wrdApp = New Word.Application object and declare doc and newdoc explicitely as Word.Document.
Disclaimer 2: Since you search for text instead of the respective heading, beware that this will find the first occurence of that text so you better not have the same text in several chapters. ;-)
Disclaimer 3: I cannot paste anymore! :-( My clipboard is set, it pastes elsewhere but I just cannot paste in here.
Code follows with first edit, hopefully in a minute...
Edit: yepp, pasting works again. :-)
Sub FindChapter()
Dim doc As Document, newdoc As Document
Dim startrange As Long, endrange As Long
Dim HeadingToFind As String, ChapterToFind As String
ChapterToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = ChapterToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
'**********
'Find preceding heading to know where chapter starts
'**********
.Collapse wdCollapseStart
With .Find
.Text = ""
.Style = "Heading 1"
.Forward = False
.Execute
If Not .Found Then
MsgBox "Could not find chapter heading"
Exit Sub
End If
End With
.MoveDown Count:=1
.HomeKey unit:=wdLine
startrange = .Start
'*********
'Find next heading to know where chapter ends
'*********
.Find.Forward = True
.Find.Execute
.Collapse wdCollapseStart
.MoveUp Count:=1
.EndKey unit:=wdLine
endrange = .End
doc.Range(startrange, endrange).Copy
newdoc.Content.Paste
newdoc.SaveAs2 doc.Path & "\" & HeadingToFind & ".docx", wdFormatFlatXML
Else
MsgBox "Chapter not found"
End If
End With
End Sub
Edit: If you need to search for a "feature" that will be in some table in column 1 with the description in column 2 and you need that description in a new doc, try this:
Sub FindFeature()
Dim doc As Document, newdoc As Document
Dim FeatureToFind As String
Dim ro As Long, tbl As Table
FeatureToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = FeatureToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
Set tbl = Selection.Tables(1)
ro = Selection.Cells(1).RowIndex
tbl.Cell(ro, 2).Range.Copy
newdoc.Range.Paste
End If
End With
End Sub
Edit: Slight adaptation so you can paste without overwriting existing content in newdoc:
Instead of newdoc.Range.Paste just use something along the line of this:
Dim ran As Range
Set ran = newdoc.Range
ran.Start = ran.End
ran.Paste
I'm trying to find all instances of key words in a MS Word document and change their style. The key words are stored within an array and I want to change the style of the particular word only. Ideally this would happen as I type but that is not crucial.
Attempt 1 - Based on recording a macro and changing the search term
Sub Woohoo()
Dim mykeywords
mykeywords= Array("word1","word2","word3")
For myword= LBound(mykeywords) To UBound(mykeywords)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("NewStyle")
With Selection.Find
.Text = mykeywords(myword)
.Replacement.Text = mykeywords(myword)
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
End Sub
This changes the style of the entire paragraph where the words are in.
Attempt 2 - Based on this question here How can I replace a Microsoft Word character style within a range/selection in VBA?:
Sub FnR2()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1","word2","word3")
For nKey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If IsInArray(rng, mykeywords(nKey)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next
Next
End Sub
This finds words that are in single lines but skips the words that are within a paragraph for some reason, e.g. it finds
Some text
word1
more text
but not
Some text before word1 means that the code above doesn't change the format
Word1 also isn't changed in this instance
Attempt 3 - AutoCorrect; not actually tried:
As an alternative I was thinking to use AutoCorrect. However I have more than 100 keywords and have no idea how to add this to the AutoCorrect list automatically (I'm fairly VBA illiterate). The other problem I would see with this approach is that I believe that AutoCorrect is global, whereas I need this only to work for a specific document.
I believe the reason why your macro isn't finding the words is due to the presence of leading or trailing blank spaces. Providing that you have already defined the style "NewStyle" changing your if statement in SubFnR2 from
If IsInArray(rng, mykeywords(nKey)) Then
to
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Should solve the issue. By the way if you want to keep the style of the word depending on whether it is upper or lower case then remove the LCase part.
Edit:
I have included the sub with the modification below. I have tested it on the examples you gave (cut and pasted into word) and it changed the style for both instances word1.
Sub FnR3()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub
Ok, your document behaves has you described, I'm not quite sure why. I checked selecting the range and just the word was selected, but then the whole paragraph was formatted. I have modified the code to modify the selection, shown below. This did just change the word.
Sub FnR4()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
Selection.Collapse
rng.Select
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Selection.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub