WORD - Find and replace text via Text in quotation marks - vba

How Can I find and trim spaces between quotation text?
for example: if the word contains the following string:
I say to him ' why should I? ' he answers...
It will replace:
I say to him 'why should I?' he answers...
I know that the regular expression to find text in the quotation is:(\'*?\') but from here I could not progress.
Any help will be highly appreciated
Asi

For a VBA solution, try:
Sub Demo()
Dim Rng As Range, Rslt
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[‘'][!^13^l^t]#['’]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
.Select
Set Rng = .Duplicate
With Rng
.Start = .Start + 1
.End = .End - 1
If .Text <> Trim(.Text) Then
Rslt = MsgBox("Trim this instance?", vbYesNoCancel)
If Rslt = vbCancel Then Exit Sub
If Rslt = vbYes Then
Do While .Characters.Last = " "
.Characters.Last = vbNullString
Loop
Do While .Characters.First = " "
.Characters.First = vbNullString
Loop
End If
End If
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Sub
Note: If the strings don't have any formatting applied, you could reduce:
Do While .Characters.Last = " "
.Characters.Last = vbNullString
Loop
Do While .Characters.First = " "
.Characters.First = vbNullString
Loop
to:
.Text = Trim(.Text)
To work with just a selected range, change:
Dim Rng As Range, Rslt
With ActiveDocument.Range
to:
Dim Rng As Range, RngSel As Range, Rslt
With Selection.Range
Set RngSel = .Duplicate
and insert:
If .InRange(RngSel) = False Then Exit Sub
before:
.Select

Related

Macro to Replace Pronouns with Conditional Merge Field

I need a macro that replaces his/her or he/she with a conditional merge field. Thanks to another website, I was able to replace these pronouns with a merge field, but not a conditional merge field without crashing MS Word. Below is the code that I used.
Sub TestAddIf()
Dim doc As Word.Document
Dim mRng As Range
Set doc = ActiveDocument
Set mRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:="he")
doc.MailMerge.Fields.AddIf mRng, _
MERGEFIELD:="""Client_Sex""", Comparison:=wdMergeIfEqual, CompareTo:="M", _
truetext:="he", _
falsetext:="she"
mRng.Collapse wdCollapseEnd
Loop
End With
End Sub
Try the following macro, which deals with 'he', 'his', 'him', and 'male' throughout the document (delete the ',male' & ',female' terms if you don't want them).
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, RngFld As Range, StrFnd As String, StrRep As String, StrCode As String, i As Long, j As Long
StrM = "he,his,him,male": StrF = "she,her,her,female"
With ActiveDocument
For i = 0 To UBound(Split(StrM, ","))
StrCode = "IFX= ""M"" """ & Split(StrM, ",")(i) & """ """ & Split(StrF, ",")(i) & """"
j = Len(StrCode) + 4
Set Rng = .Range(0, 0)
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:=StrCode, PreserveFormatting:=False
Rng.End = Rng.End + j
.Fields.Add Range:=Rng.Characters(5), Type:=wdFieldEmpty, Text:="MERGEFIELD Client_Sex", PreserveFormatting:=False
Rng.Cut
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.Text = Split(StrM, ",")(i)
.Replacement.Text = "^c"
.Execute Replace:=wdReplaceAll
End With
Next
End With
Application.ScreenUpdating = True
End Sub

How can I convert a word to a hyperlink linking to a Bookmark in the same document?

I really have problems with this one. Imagine I have the word „stackoverflow“. At the end of the document there is a glossary. Now I need a macro that searches for all occurences of stackoverflow and replaces them with a hyperlink to the bookmark in the table. A reader still sees „stackoverflow“ but can click on it to jump to the Glossary. I can insert online links in „address“ field and think I need the subaddress field but do not know what to put there.. Thank you in advance!
Sub Convert_String()
Dim Word
Dim R As Range
Dim Tabellenanzahl
Dim T As Table
Dim Link As Hyperlink
Set R = ActiveDocument.Range
Tabellenanzahl = ActiveDocument.Tables.Count
Set T = ActiveDocument.Tables(Tabellenanzahl)
ActiveDocument.Bookmarks.Add "Anker", T.Range
For Z = 2 To T.Rows.Count
Set Wort = T.Cell(Z, 1)
With R.Find
.ClearFormatting
.Text = Word
.Forward = True
.Wrap = wdFindStop
End With
Do While R.Find.Execute
R.Hyperlinks.Add Anchor:=Selection, SubAddress:="Anker", TextToDisplay:="GoToGlossaryTest"
Loop
Next
End Sub
Try:
Sub GlossaryLinker()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, HLnk As Hyperlink
Dim strFnd As String, BkMkNm As String, r As Long
With ActiveDocument
Set Tbl = .Tables(.Tables.Count)
For r = 2 To Tbl.Rows.Count
With Tbl.Cell(r, 1)
Set Rng = .Range
With Rng
.End = .End - 1
strFnd = Trim(Split(.Text, vbCr)(0))
BkMkNm = Replace(strFnd, " ", "_")
.Bookmarks.Add BkMkNm, .Duplicate
End With
End With
Set Rng = .Range(.Range.Start, Tbl.Range.Start)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Text = strFnd
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchCase = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) = False Then Exit Do
Set HLnk = .Hyperlinks.Add(.Duplicate, , BkMkNm, , .Text)
.End = HLnk.Range.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
End With
Application.ScreenUpdating = True
End Sub

move parenthesis to comment in local range in Microsoft Word using VBA

I am trying to move all the text I have in parenthesis to a comment in a range I select. I am almost there but for some reason it only works at the start of the range. My macro is as follows:
Sub CommentOutParenthsLocal()
'
' CommentBubble Macro
'
'
Dim myRange As Range
Set myRange = Selection.Range
searchText = "\(*\)"
With myRange.Find
.MatchWildcards = True
Do While .Execute(findText:=searchText, Forward:=True) = True
ActiveDocument.Comments.Add myRange, myRange.Text
myRange.Text = ""
Loop
End With
End Sub
Any advice?
Based on your description, you need to limit your code's scope to what you've actually selected, amongst other things. In that case, try:
Sub CommentOutParenthsLocal()
Application.ScreenUpdating = True
Dim myRange As Range
Set myRange = Selection.Range
With Selection.Range
With .Find
.Text = "\(*\)"
.Forward = True
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
If .InRange(myRange) = False Then Exit Do
.Comments.Add .Duplicate, .Text
.Text = vbNullString
.Find.Execute
Loop
End With
Application.ScreenUpdating = False
End Sub

Select code snippet in document, using the VBA

I want to create a macro, which will allow to select entire code blocks in the document.
This is what I currently have:
Sub SelectSnippet()
Selection.Find.Style = ActiveDocument.Styles("Code")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
End Sub
The problem is, that it selects only the next line of code, instead of snippet entirely.
Visually:
This code should do the job. Please try.
Sub SelectSnippet()
Dim Styl As Variant
Dim Rng As Range
Dim Fnd As Boolean
Styl = "Code"
Set Rng = Selection.Range ' start at the selection
' find the nearest different style before the selection
With Rng
Do While .Start > 1
If .Style <> Styl Then Exit Do
.Move wdCharacter, -1
Loop
End With
' look for the first occurrance of the style
On Error Resume Next
With Rng.Find
.Text = ""
.Style = Styl
Fnd = .Execute
End With
If Err Then
MsgBox Err.Description, vbInformation, "Can't find """ & Styl & """"
End If
If Fnd Then
' expand the range to the end of the style
With Rng
Do While .End < .Document.Characters.Count
If .Document.Range(.End, .End + 1).Style <> Styl Then Exit Do
.MoveEnd wdCharacter, 1
Loop
.Select ' select the range
End With
End If
End Sub
The following code does the same job but looks at complete paragraphs only. If a part of a paragraph isn't of the same style it may or may not be included.
Sub NewSelectSnippet()
Dim Styl As Variant
Dim Rng As Range
Dim DocRng As Range
Dim p As Integer
Styl = "Code"
' expand the section to include the entire paragraph
Set Rng = Selection.Paragraphs(1).Range
If Rng.Style <> Styl Then Exit Sub
' expand the range to include preceding paragraphs of same style
Set DocRng = ActiveDocument.Range(0, Rng.End)
With DocRng.Paragraphs
For p = .Count To 1 Step -1
If .Item(p).Range.Style = Styl Then
Rng.MoveStart wdParagraph, -1
Else
Exit For
End If
Next p
End With
' expand the range to include following paragraphs of same style
With ActiveDocument.Paragraphs
For p = (DocRng.Paragraphs.Count + 1) To .Count
If .Item(p).Range.Style = Styl Then
Rng.MoveEnd wdParagraph, 1
Else
Exit For
End If
Next p
End With
Rng.Select
End Sub

Searching for words in word, but ignoring tables

I have the fantastic macro below which
Searches for words (listed in an excel file)
Copies each instance
Pastes into a new word document together with it's location from the original document
This has been created and amended by various people and I am truly greatful!!. One thing that I was wondering if possible is:
If in the word document which you're searching there are tables, can you make the macro to ignore tables? or would it be better to say 'If the word is found and is in a table ignore this instance and proceed searching te document again'
The latter would have more unnecessary iterations in my opinion.
I had managed to find the code:
Sub NonTableParagraphs()
Dim rng() As Range
Dim t As Integer
Dim tbl As Table
Dim para As Paragraph
Dim r As Integer
ReDim Preserve rng(t)
Set rng(t) = ActiveDocument.Range
For Each tbl In ActiveDocument.Tables
rng(t).End = tbl.Range.Start
t = t + 1
ReDim Preserve rng(t)
Set rng(t) = ActiveDocument.Range
rng(t).Start = tbl.Range.End
Next tbl
rng(t).End = ActiveDocument.Range.End
For r = 0 To t
For Each para In rng(r).Paragraphs
'do processing
Next para
Next r
End Sub
and had tried to insert NonTableParagraphs in the original macro, so it would run a sub routine, but I couldn't get it to work.
It looks like I should be trying to use ActiveDocument.Tables and somehow stating if ActiveDocument.Tables found, skip the rest of the lines in macro & then return to searching after the table but I can't seem to get it to work.
I'll see if I can search for that
Many thanks!!!
Sub CopyKeywordPlusContext()
'Modified 3-10-2015 TW
'Modified 2-17-2015 GKM
'Makro created on 22.01.2013
Dim oDoc As Document, oDocRecord As Document
Dim strSearch As String, arrSearch
Dim lngCharTrailing As Long, lngCharLeading As Long, lngIndex As Long, lngCount As Long
Dim lngPgNum, lngLineNum As Integer
Dim oRng As Word.Range, oRngSpan As Word.Range
Dim bFound As Boolean
Dim oTbl As Word.Table
strSearch = vbNullString
Dim xl As Object
Set xl = GetObject(, "Excel.Application")
arrSearch = xl.transpose(xl.activesheet.Range("A1:A221").Value)
lngCharLeading = 20
lngCharTrailing = 20
Set oDoc = ActiveDocument
For lngIndex = 1 To UBound(arrSearch)
ResetFRParams
bFound = False
lngCount = 0
Set oRng = oDoc.Range
With oRng.Find
.Text = LCase(arrSearch(lngIndex))
While .Execute
bFound = True
If oDocRecord Is Nothing Then
Set oDocRecord = Documents.Add
Set oTbl = oDocRecord.Tables.Add(oDocRecord.Range, 1, 2)
End If
lngCount = lngCount + 1
If lngCount = 1 Then
oTbl.Rows.Add
With oTbl.Rows.Last.Previous
.Cells.Merge
With .Cells(1).Range
.Text = "Search results for """ & arrSearch(lngIndex) & """ + context in " & """" & oDoc.Name & """"
.Font.Bold = True
End With
End With
End If
Set oRngSpan = oRng.Duplicate
oRngSpan.Select
lngPgNum = Selection.Information(wdActiveEndPageNumber)
lngLineNum = Selection.Information(wdFirstCharacterLineNumber)
With oRngSpan
.MoveStart wdCharacter, -lngCharLeading
.MoveEnd wdCharacter, lngCharTrailing
Do While oRngSpan.Characters.First = vbCr
oRngSpan.MoveStart wdCharacter, -1
Loop
Do While oRngSpan.Characters.Last = vbCr
oRngSpan.MoveEnd wdCharacter, 1
If oRngSpan.End = oDoc.Range.End Then
oRngSpan.End = oRngSpan.End - 1
Exit Do
End If
Loop
End With
oTbl.Rows.Last.Range.Cells(1).Range.Text = Trim(oRngSpan.Text)
oTbl.Rows.Last.Range.Cells(2).Range.Text = "Page: " & lngPgNum & " Line: " & lngLineNum
oTbl.Rows.Add
Wend
End With
If bFound Then
ResetFRParams
With oDocRecord.Range.Find
.Text = LCase(arrSearch(lngIndex))
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Format = True
.Execute Replace:=wdReplaceAll
End With
End If
Next lngIndex
oTbl.Rows.Last.Delete
End Sub
Sub ResetFRParams()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Replacement.Highlight = False
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
lbl_Exit:
Exit Sub
End Sub
Instead of trying to debug/edit your code look at this and decide for yourself where to insert it.
Sub FindText()
Dim doc As Word.Document, rng As Word.Range
Set doc = Word.ActiveDocument
Set rng = doc.Content
With rng.Find
.ClearFormatting
.Format = False
.Forward = True
.Text = "Now is"
.Wrap = wdFindStop
.Execute
Do While .Found
If rng.Information(Word.WdInformation.wdWithInTable) Then
'do nothing
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Else
rng.Text = "Now is not"
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
End If
.Execute
Loop
End With
End Sub