Would like to ask for any advice on how to convert a sentence in to Title case with the exception of acronyms (or any words that is in all caps) in Microsoft Word. Currently my code only converts all the sentences in a specific style in Title case. Hoping you could help with with this. Thank you
Sub ChangeCase() StrFind = "K-1,K-2,K-3"
For i = 0 To UBound(Split(StrFind, ","))
With Selection.Find
.ClearFormatting
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchWildcards = False
.Text = ""
.Style = Split(StrFind, ",")(i)
.Execute
While .Found
Selection.Range.Case = wdTitleWord
Selection.Collapse Direction:=wdCollapseEnd
.Execute
Wend
End With
Next i
End Sub
If the objective is to TitleCase words that aren't already fully capitalized, I think the below should work.
Option Explicit
Public Sub TitleCaseDocument()
Dim doc As Document: Set doc = ThisDocument
Dim wrd As Range
For Each wrd In doc.Words
If wrd.Text <> UCase$(wrd.Text) Then wrd.Case = wdTitleWord
Next
End Sub
Related
I am trying to create a Word macro that will:
Search for a specific word (i.e. "see")
Select the entire paragraph where that word appears
Make the whole paragraph a different style (i.e. make it all red text)
Do the same thing with a second word (i.e. "blacklist")
Select that whole paragraph and apply a different style (i.e. again, make the paragraph red text)
Copy all paragraphs with the red text style and paste them in to a new word document
Unfortunately, I'm no VBA expert and I'm trying to cobble things together from what I can find online. I have found a great example that will select to the start of the paragraph, but I can't seem to figure out how to select the entire paragraph. Any help is appreciated!
** Sorry - here is the code I currently have. It will find all instances of the word "see" and selects to the start of the paragraph, then changes the color to red... but that's as far as I've gotten, as I am stuck on trying to figure out how to get it to select to the end of the paragraph.
Sub TestOne()
'
' TestOne Macro
'
'
If MsgBox(Prompt:="Would you like to update selected paragraph styles?", Buttons:=vbYesNo + vbQuestion, _
Title:="Format MD Report") = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "see"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
i = i + 1
.Start = .Paragraphs.First.Range.Start
.Font.Color = wdColorRed
.Start = .Paragraphs.First.Range.End
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
For example, without needing to create a second document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
StrFnd = "see|blacklist"
With ActiveDocument.Range
.Font.Hidden = True
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Font.Hidden = True
.Replacement.Font.Hidden = False
.Format = True
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = "[!^13]#" & Split(StrFnd, "|")(i) & "*^13"
.Execute Replace:=wdReplaceAll
Next
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
You could, of course, add a line of code before the final 'End With' to save the document with a new name.
To select the entire paragraph, following the line
.Start = .Paragraphs.First.Range.Start
add
.End = .Paragraphs.First.Range.End
... then to match only whole words, after
.MatchWildcards = False
add
.MatchWholeWord = True
And to run the code for multiple words you should add a parameter to your Sub eg
Sub TestOne(theWord As String)
then replace
.Text = "see"
with
.Text = theWord
And to run your code for each required word, add a Sub such as
Sub RunMe()
TestOne "see"
TestOne "blacklist"
End Sub
... optionally, move your MsgBoxes into RunMe()
I would like to apply a character style ("Bold Italics") to the first two words of all paragraphs set in the "3 Species" style in MS Word (and later, I'd also like another macro to do same for all the words after the second tab in a different style). I know how to do all this in InDesign, but I'd like it set up in the original Word documents before they get flowed into InDesign.
I'm new at this and can't figure out how to apply it to only the first two words. I did get it to apply the character style to the whole paragraph or to a specific word in that style. It seems like it ought to be simple, but I've only learned to use find and replace type functions so far, and I imagine I will have to use the Range functions, which I don't understand yet. Thanks for any help!
Sub Add_Character_Style()
'
' Add_Character_Style Macro
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Style = "3 Species"
.Text = ""
.Replacement.Text = ""
.Replacement.Style = "Bold Italics"
.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
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<*>[,. ^s^t]#<*>"
.Style = "3 Species"
.Replacement.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
.Style = "Bold Italics"
.Start = .Paragraphs(1).Range.End
Loop
End With
Application.ScreenUpdating = True
End Sub
Try this:
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
For Each p In doc.Paragraphs
p.Range.Select
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
With Selection
If .Style = "3 Species" Then .Style = "Bold Italic"
End With
Next p
End Sub
EDIT:
To avoid use of the Selection object (Timothy Rylatt)
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
Dim rng As Range
For Each p In doc.Paragraphs
If p.Range.Style = "3 Species" Then
Set rng = p.Range
With rng
.Collapse Direction:=wdCollapseStart
.MoveEnd Unit:=wdWord, Count:=2
.Style = "Bold Italics"
End With
End If
Next p
End Sub
FURTHER EDIT per macropod:
Sub Add_Character_Style()
Application.ScreenUpdating = False
Dim Para As Paragraph, Rng As Range
For Each Para In ActiveDocument.Paragraphs
With Para
If .Style = "3 Species" Then
If .Range.ComputeStatistics(wdStatisticWords) > 1 Then
Set Rng = .Range.Words.First
With Rng
Do While .ComputeStatistics(wdStatisticWords) < 2
.MoveEnd wdWord, 1
Loop
.Style = "Bold Italic"
End With
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
We are trying to revise rtf docs that are created by Molecular Device software.
Here is an example of part of one of these documents:
Protocol 'C:\ALL USERS\Params\Current\2017 Opto Params\0 VoltageClampContinuous.pro' opened.
C:\ALL USERS\Alan\2018_07_11\2018_07_11_0000.abf started at 00:19:48 stopwatch time.
So for right now - all I am trying to do is automatically find the experiment date (in this case = "2018_07_11_")
My sub so far can find the correct cursor positions but how do I select the text between 2 cursor positions?
Below is what I have the CursorPosition statement is of course wrong - this is what I am looking to correct.
Sub FindfilenameDate()
txt_prior_to_expDate = "\"
txt_after_expDate = "0000"
With ActiveDocument.Content.Find
.Text = txt_after_expDate
.Forward = True
.Execute
If .Found = True Then
.Parent.Select
Set after_rng = Selection.Range
expDateEnd_cursorPos = after_rng.Start - 1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
With Selection.Find
.Text = txt_prior_to_expDate
.Forward = False
.Execute
If .Found = True Then
.Parent.Select
Set charBefore_expDate = Selection.Range
expDateStart_cursorPos = charBefore_expDate.Start + 1
End If
End With
End If
End With
'expDate = CursorPosition(expDateStart_cursorPos, expDateEnd_cursorPos)
'MsgBox ("expDate = " & expDate) 'DELETEMSGBOX
End Sub
The trick to something like this is to work with multiple Range objects. My personal preference is to declare a Range for each separate thing to be worked with, rather than trying to figure out the minimum and re-use a Range - at least for the initial code and testing purposes.
For this task, then, I use four Ranges: 1) For the original search, 2) for the end of the "cursor position" that's wanted, 3) For the second search, 4) for the final "cursor position".
The other important concepts are how to "collapse" a Range and how to "copy" one.
Collapsing a Range is like pressing the right- or left-arrow key with a selection, so that it is a "point" and doesn't contain anything. A Range can be collapsed to its start or end position.
Copying a Range (setting one Range to another) needs to be done using the Duplicate property so that the copy is independent of the original. Otherwise, when one is changed the other changes, as well.
Sub FindfilenameDate()
Dim rngFind As Word.Range, rngBefore As Word.Range
Dim rngAfter As Word.Range, rngFound As Word.Range
txt_prior_to_expDate = "\"
txt_after_expDate = "0000"
Set rngFind = ActiveDocument.content
With rngFind.Find
.Text = txt_after_expDate
.Forward = True
.Execute
If .found = True Then
Set rngAfter = rngFind.Duplicate
rngAfter.Collapse wdCollapseStart
Set rngBefore = rngFind.Duplicate
rngBefore.Collapse wdCollapseStart
With rngBefore.Find
.Text = txt_prior_to_expDate
.Forward = False
.Execute
If .found = True Then
Set rngFound = rngBefore.Duplicate
rngFound.Collapse wdCollapseEnd
rngFound.End = rngAfter.Start
'rngFound.Select
End If
End With
End If
End With
'expDate = CursorPosition(expDateStart_cursorPos, expDateEnd_cursorPos)
MsgBox ("expDate = " & rngFound.Text) 'DELETEMSGBOX
End Sub
Though it's not apparent why you're after the date string ending in _0000 rather than the date that is the parent folder name, a much simpler approach for a single date would be:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{4}_[0-9]{2}_[0-9]{2}_0000"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found = True Then MsgBox "expDate = " & Split(.Text, "_0000")(0)
End With
Application.ScreenUpdating = True
End Sub
And, for all such dates in a document:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{4}_[0-9]{2}_[0-9]{2}_0000"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
MsgBox "expDate = " & Split(.Text, "_0000")(0)
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
I using Macro to find word from checklist and highlight in Word document. But If word not found from list then. I also want to highlight matching word in checklist so that I know these word found and these word missing.
One more It also search word inside word that also need to modify. i.e.
if in checklist I have word Country but it find Count too, I want if find whole word. But first problem is most important.
Sub CompareWordList1()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
sCheckDoc = "D:\List.docx"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = wdDarkRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
End With
For Each wrdRef In docRef.Words
If Asc(Right(wrdRef, 1)) > 32 Then
With Selection.Find
.Wrap = wdFindContinue
.Text = wrdRef
.Execute Replace:=wdReplaceAll
End With
End If
Next wrdRef
docRef.Close
docCurrent.Activate
End Sub
The key is that .Execute Replace:=wdReplaceAll returns True if the operation was successful and False if nothing was replaced. So we can use this to determine if the word was found or not.
So we can write a function that highlights one word in a document, so that we can re-use that function for different words and different documents:
Option Explicit
Public Function HighlightOneWordInDocument(DocToHighlight As Document, ByVal WordToHighlight As String) As Boolean
If Len(WordToHighlight) = 0 Then Exit Function 'exit if no WordToHighlight is empty otherwise below if fails
If Asc(Right(WordToHighlight, 1)) > 32 Then
With DocToHighlight.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = wdDarkRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
.Wrap = wdFindContinue
.Text = WordToHighlight
HighlightOneWordInDocument = .Execute(Replace:=wdReplaceAll)
End With
End If
End Function
Then we can use that function to replace a word in a specific document and it returns if True if the word was replaced:
HighlightOneWordInDocument(docCurrent, wrdRef)
'returns true if wrdRef was replaced in docCurrent
So we just need to remember the words that were found in an array, so that we can use that array to highlight your word list in the end:
Sub CompareWordList1()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
sCheckDoc = "D:\List.docx"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
Dim FoundWords() As String
ReDim FoundWords(0)
For Each wrdRef In docRef.Words
If HighlightOneWordInDocument(docCurrent, wrdRef) = True Then
'if something was replaced remember this word in the FoundWords array
ReDim Preserve FoundWords(UBound(FoundWords) + 1)
FoundWords(UBound(FoundWords)) = wrdRef
End If
Next wrdRef
'now we go throug the FoundWords array to highlight the list
Dim FoundWord As Variant
For Each FoundWord In FoundWords
HighlightOneWordInDocument docRef, FoundWord
Next FoundWord
docRef.Close 'to save the highligted ist use docRef.Close SaveChanges:=True
docCurrent.Activate
End Sub
I have a text with five 'XX' scattered at different places. I'd like to
replace the first instance of XX by 1., the second instance by 2. and
so, until replacing the fifth instance by 5. I tried to use the
following code without success:
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "XX"
.Replacement.Text = "1."
.Execute Replace:=wdReplaceOne
.Forward = True
.Text = "XX"
.Replacement.Text = "2."
.Execute Replace:=wdReplaceOne
.Forward = True
[...]
.Text = "XX"
.Replacement.Text = "5."
.Execute Replace:=wdReplaceOne
.Wrap = wdFindStop
End With
End Sub
How can I modify the above code, or what else should I do to get these substitutions? If I use "sed" on a text file, I'd simply do: s/XX/1./1, s/XX/2./2, s/XX/3./3, etc.
What you can do is use a For...Next loop to increment a counter, using the counter as the replacement text. This will save having to write lots of repeated code, as the first code sample shows.
The code can be made more flexible, for any number of occurrences of the search term, by using a Do...Until loop that repeats until no more instances of the search term are found. This variation is in the second code example.
Both variations contain code to search either the entire document or the current selection. Just comment out the one you don't need and remove the comment from the one you do...
Sub FindAndReplaceWithNumbers()
Dim rngDoc As word.Range, rngFind As word.Range
Dim findString As String
Dim counter As Long
Dim found As Boolean
findString = "XX"
'To search the entire document
'Set rngDoc = ActiveDocument.content
'To search a selection, only
Set rngDoc = Selection.Range
Set rngFind = rngDoc.Duplicate
With rngFind.Find
.ClearFormatting
.Replacement.ClearFormatting
.wrap = wdFindStop
.Forward = True
.Text = findString
End With
For counter = 1 To 5
With rngFind.Find
.Replacement.Text = CStr(counter) & "."
found = .Execute(Replace:=wdReplaceOne)
End With
rngFind.End = rngDoc.End
Next
End Sub
Sub FindAndReplaceWithNumbers()
Dim rngDoc As word.Range, rngFind As word.Range
Dim findString As String
Dim counter As Long
Dim found As Boolean
findString = "XX"
counter = 1
'To search the entire document
'Set rngDoc = ActiveDocument.content
'To search a selection, only
Set rngDoc = Selection.Range
Set rngFind = rngDoc.Duplicate
With rngFind.Find
.ClearFormatting
.Replacement.ClearFormatting
.wrap = wdFindStop
.Forward = True
.Text = findString
End With
Do
With rngFind.Find
.Replacement.Text = CStr(counter) & "."
found = .Execute(Replace:=wdReplaceOne)
End With
rngFind.End = rngDoc.End
counter = counter + 1
Loop Until Not found
End Sub
Simpler and faster:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "XX"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + 1
.Text = i
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " records updated."
End Sub
To limit the code's scope to a Selection, you could use:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With Selection
Set Rng = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "XX"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
i = i + 1
.Text = i
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
MsgBox i & " records updated."
End Sub