extreme VBA noob here. I'm trying to write a macro that searches for every tab and the letter following it, and replaces it with a tab and that capitalised letter.
I've figured out the following using internet articles around the place, but I'm not sure how to correctly write the Replacement.Text line. Thanks in advance.
Sub Capitaliser()
With Selection.Find
Text = "^t?"
Replacement.Text = UCase(Text)
Forward = True
Wrap = wdFindContinue
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = True
MatchSoundsLike = False
MatchAllWordForms = False
Execute Replace:=wdReplaceAll
End With
End Sub
Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^t[a-z]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
.Text = UCase(.Text)
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
Related
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
I am trying to figure a way to convert intext notes (notes and references within the text body) to endnotes in an MS Word document that has existing endnotes and this is my first macro in decades.
My intext notes can be identified since they are in dark blue between curled brackets. So far I managed to record a macro for the single steps: Search for pattern, cut pattern, insert endnote, paste pattern, search pattern again in endnotes, remove curled brackets, focus back to the beginning of the document (out of endnotes).
Here is how it looks:
Sub inline2endnote()
Selection.Find.ClearFormatting
Selection.Find.Font.Color = 6299648
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "\{(*?)\}"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Selection.Cut
With Selection
With .EndnoteOptions
.Location = wdEndOfDocument
.NumberingRule = wdRestartContinuous
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End With
.Endnotes.Add Range:=Selection.Range, Reference:=""
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Find.ClearFormatting
Selection.Find.Font.Color = 6299648
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "\{(*?)\}"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
With Selection
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseStart
Else
.Collapse Direction:=wdCollapseEnd
End If
.Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseEnd
Else
.Collapse Direction:=wdCollapseStart
End If
.Find.Execute
End With
Selection.HomeKey Unit:=wdStory
End Sub
I had to focus back on top because I needed to exit the endnotes section and go back to body text. Also, I have no idea what the last "With" section is meant to do.
Now I would like to loop this pattern in order to fix all the inline notes, but I seem unable to find away. I was using this thread as a reference but I can't figure out how to properly set my scope and define the fields for my iterations.
I was also wondering if there is a cleaner way to write the steps, like pasting my content without curled brackets directly, like store my find in a variable and use a second one with stripped content.
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, E_Nt As Endnote
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "\{[!\{]#\}"
.Font.Color = 6299648
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
Set Rng = .Duplicate
With Rng
.Start = .Start + 1
.End = .End - 1
End With
Set E_Nt = .Endnotes.Add(.Duplicate)
E_Nt.Range.FormattedText = Rng.FormattedText
E_Nt.Range.Font.ColorIndex = wdAuto
.Text = vbNullString
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
I am trying to create VBA to insert before and after Supercript and subscript. My code is below.
Public Sub MySubscriptSuperscript()
Dim myRange As Word.Range, myChr
For Each myRange In ActiveDocument.StoryRanges
Do
For Each myChr In myRange.Characters
If myChr.Font.Superscript = True Then
myChr.Font.Superscript = False
myChr.InsertBefore "<sup>"
myChr.InsertAfter "</sup>"
End If
If myChr.Font.Subscript = True Then
myChr.Font.Subscript = False
myChr.InsertBefore "<sub>"
myChr.InsertAfter "</sub>"
End If
Next
Set myRange = myRange.NextStoryRange
Loop Until myRange Is Nothing
Next
End Sub
This code is working good for each character of superscript and subscript.
But, I am looking for VBA which insert tags before and after complete superscript/subscript word/letters.
Example
C12H22O11 and x23 + y397 + x67
Above VBA is giving following Output
C<sub>1</sub><sub>2</sub>H<sub>2</sub><sub>2</sub>O<sub>1</sub><sub>1</sub><sub> </sub><sub> </sub> and x<sup>2</sup><sup>3</sup> + y<sup>3</sup><sup>9</sup><sup>7</sup> + x<sup>6</sup><sup>7</sup>
But I am looking for this output
C<sub>12</sub>H<sub>22</sub>O<sub>11</sub> and x<sup>23</sup> + y<sup>397</sup> + x<sup>67</sup>
Pls guide, how this can be achieved.
I would be tempted to go for easiest way to get the end result - at the end, simply do a replace of </sub><sub> and </sup><sup> with an empty string "".
But then, I am lazy this way...
Edit - just an idea:
wouldn't it be faster to do the whole thing with replace? You wouldn't have to check every character. Here is what Word does record for the replacement, it would need a bit of polishing:
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Superscript = False
.Subscript = False
End With
With Selection.Find
.Text = "^?"
.Replacement.Text = "<sup>^&</sup>"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
So, at the end, you would run search&replace 4 times:
replace superscript
delete the closing and opening tags for superscript
replace subscript
delete the closing and opening tags for subscript
Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Text = ""
.Wrap = wdFindContinue
.Font.Subscript = True
.Replacement.Text = "<sub>^&<\sub>"
.Execute Replace:=wdReplaceAll
.Font.Superscript = True
.Replacement.Text = "<sup>^&<\sup>"
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
It's not apparent why you'd be looping through all storyranges, as such content would ordinarily only be in the document body. That said, it's easy enough to modify the code to work with all storyranges.
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 a Word table where I apply a routine that replaces paragraph marks with a comma and a space. However, in doing so there is now some text like '..., There...' and my client wanted to replace the Upper Case to Lower Case as much as possible.
So, I wrote some secondary code that I call from the previous routine as follows:
Sub LowerCaseAfterComma()
With Selection.Find
.ClearFormatting
.Text = ", ([A-Z])"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
While .Found
Selection.Range.Case = wdLowerCase
Selection.Collapse Direction:=wdCollapseEnd
.Execute
Wend
End With
End Sub
Although this identifies the instances of Upper Case characters in the table and replaces them accordingly, the code then looks for all other instances outside the table in the document, which I don't want the code to do. I have tried using the Range object in Word for the table I want edited but haven't been successful in the syntax needed.
NB. I have problems in ensuring the editing stays within the specific table. There can be a differing number of tables prior to the one I wish to edit so
ActiveDocument.Tables() specifying the number of the table doesn't seem to work.
I am sure I doing some basically wrong and the code just needs a little tinkering. However, I am just a novice developer learning.
Try
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Tables(1)
Set Rng = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ", ([A-Z])"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
.Case = wdLowerCase
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub