in this code, I want to do the following:
If the word is finished with a letter M Replace with letter N.
If the word ends with a letter N, Replace with letter M.
I do not know well using the IF - Then statement.
Any help would be greatly appreciated.
Sub find_end()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[nm]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
Selection.Find.Execute
With Selection
If Selection.Find.Found = n Then
Selection.TypeText Text:=m
ElseIf Selection.Find.Found = m Then
Selection.TypeText Text:=n
End If
End Sub
I modified the code found at: Repeating Microsoft Word VBA until no search results found
and it will spin thru a document and replace the last letter (if it's an 'm' or 'n') of each word. NOTE there is a 'loop check in that code that you may want to remove if it's possible you may find over 2000 m or n's.
Option Explicit
' The following code adapted from: https://stackoverflow.com/questions/13465709/repeating-microsoft-word-vba-until-no-search-results-found
Sub SearchFN()
Dim iCount As Integer
Dim lStart As Long
'Always start at the top of the document
Selection.HomeKey Unit:=wdStory
'find a footnote to kick it off
With Selection.Find
.ClearFormatting
.Text = "[nm]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
.Execute
End With
'Jump back to the start of the document.
Selection.HomeKey Unit:=wdStory
'If we find one then we can set off a loop to keep checking
'I always put a counter in to avoid endless loops for one reason or another
Do While Selection.Find.Found = True And iCount < 2000
iCount = iCount + 1
Selection.Find.Execute
'On the last loop you'll not find a result so check here
If Selection.Find.Found Then
' Exit if we start back at the beginning
If Selection.Start < lStart Then
Exit Do
End If
'Reset the find parameters
With Selection.Find
.ClearFormatting
.Text = "[nm]>"
If Selection.Text = "m" Then
Debug.Print "found 'm' at position: " & Selection.Start
Selection.Text = "n"
ElseIf Selection.Text = "n" Then
Debug.Print "found 'n' at position: " & Selection.Start
Selection.Text = "m"
End If
lStart = Selection.Start
' .Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
End If
Loop
End Sub
Related
I am trying to remove all the occurences of more than 2 carriage returns until no more is found. The text can contain 4 consecutive carriage returns or more, so it can be 5, 8, 10...
I tried this macro copied from this site.
Sub Search3Return()
Dim iCount As Integer
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = "^p^p^p"
.Replacement.Text = "^p^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = False
.Execute
End With
'If we find one then we can set off a loop to keep checking
'put a counter in to avoid endless loops for one reason or another
Do While Selection.Find.Found = True And iCount < 1000
iCount = iCount + 1
'Jump back to the start of the document.
Selection.HomeKey Unit:=wdStory
Selection.Find.Execute
Loop
End Sub
I don't know why you even bother with VBA for this - unless it's part of a larger VBA project. All you need is a single wildcard Find/Replace, where:
Find = ^13{3,}
Replace = ^p^p
If you want the Find to not only find something but to replace it, you need to specify the Replace-parameter for the Execute-method, see https://learn.microsoft.com/en-us/office/vba/api/word.find
Sub Search3Return()
Dim iCount As Integer
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = "^p^p^p"
.Replacement.Text = "^p^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = False
Do While iCount < 1000
.Execute Replace:=wdReplaceAll
If Not .Found Then Exit Do
'Jump back to the start of the document.
Selection.HomeKey Unit:=wdStory
iCount = iCount + 1
Loop
End With
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 created a macro that finds an instance of style H1 followed by style H2, and inserts a page break between them. And reiterates this till it gets to the end of the document.
However, the macro adds multiple page breaks (maybe 50 of them) instead of just one.
what did I do wrong and how to correct this?
The code:
Sub Force_page_break()
'
' Force_page_break Macro
'
'
Dim Eloop As Integer
Eloop = 1
Selection.HomeKey Unit:=wdStory
Do While Eloop = 1
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 1")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Execute = False Then
Eloop = 0
Exit Do
End If
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
Loop
ActiveDocument.Save
End Sub
Maybe you can add a line
Eloop = Eloop + 1
after the line
Selection.InsertBreak Type:=wdPageBreak
to get out of the loop?
I have documents written in old Kazakh font (Kazakhstan), using win98. Nowadays we are using Times New Roman, but this font shows strange unicode characters. I can use substitution (Ctrl + H) to change all symbols to Times New Roman encoding, but we have 42 (84 in both cases) letters.
For example I have all symbols from old font in first line, and all symbols from new font at the second line in the same order.
Can someone write an example script that will read this two lines char by char, making something like a dictionary in Java then do a global substitution.
Update
Thanks Roman Plischke!
I wrote a macro that recursively applies to all *.doc files in some folder.
Sub Substitution()
'
' Substitution of the chars from font Times/Kazakh
' to Times New Roman
' Chars to substitute are 176-255 bytes, 73 and 105 byte
Dim sTab As String
sTab = "£ª½¥¡¯Ž¼º¾´¢¿žÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ"
Selection.Find.Font.Shadow = False
Selection.Find.Replacement.Font.Shadow = False
For i = 1 To Len(sTab)
With Selection.Find
.Text = ChrW(i + 175)
.Replacement.Text = Mid(sTab, i, 1)
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Text = Selection.Find.Text
Next i
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = ChrW(105)
.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
Selection.Find.Text = Selection.Find.Text
With Selection.Find
.Text = ChrW(73)
.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
Selection.Find.Text = Selection.Find.Text
' kazakh language
Selection.WholeStory
Selection.LanguageID = WdLanguageID.wdKazakh
Application.CheckLanguage = False
Selection.Collapse Direction:=wdCollapseStart
End Sub
' Function that Call Substitution() for all documents
' in folder vDirectory
Sub LoopDirectory()
Dim vDirectory As String
Dim oDoc As Document
vDirectory = "E:\soft\Dedushka\not\"
vFile = Dir(vDirectory & "*.doc")
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
Debug.Print ActiveDocument.Name + " Started"
Call Zamena
Debug.Print ActiveDocument.Name + " Finish"
oDoc.Close SaveChanges:=True
vFile = Dir
Loop
End Sub
I used for similar conversions this subroutine. The "heart" of code is a definition of string sTab. This string contains all charactesr for code 127 and above. Fill this string by new characters one by one.
If you have a code table of the old Kazakh coding, it is very simple: type in the VBA editor all characters starting 127 char. VBA editor works in Unicode, so this works.
If you have not a code table, you have to get an old code of each character (try select this character and press Alt+X) and write it manually in the string at right position.
In both cases, for unused (or unusually) character you may fill a space or other character.
The rest of code replaces each character with code above 127 for new character from sTab.
Sub Convert()
Dim sTab As String
Dim sKod As String
Dim i As Long
Dim ch As String
'new chars 127-255:
'note: for each character above 127 fill in this table unicode character
sTab = "ÄÃãÉ¥ÖÜá¹ÈäèÆæéŸÏí“”ëEóeôöoúÌìü†°Ê£§•¶ß®©™ê¨‡gIlÎ__îK__³Ll¼¾ÅåNnѬVñÒ_«»… òÕOõO–—“”‘’÷_OÀàØ‹›øRrŠ‚„šŒœÁÍŽžUÓÔuÙÚùÛûUuÝýk¯£¿G¡"
'clear all shadow - we use this attrib as flag for changed characters
Selection.Find.ClearFormatting
Selection.Find.Font.Shadow = True
Selection.Find.replacement.ClearFormatting
Selection.Find.replacement.Font.Shadow = False
With Selection.Find
.Text = ""
.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
'changing characters by codetable
Selection.Find.Font.Shadow = False
Selection.Find.replacement.Font.Shadow = True
For i = 1 To Len(sTab)
With Selection.Find
ch = Chr(126 + i)
If ch = "^" Then ch = "^^"
.Text = ch
ch = Mid(sTab, i, 1)
If ch = "^" Then ch = "^^"
.replacement.Text = ch
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Text = Selection.Find.Text
Next i
'clear shadows
Selection.Find.Font.Shadow = True
Selection.Find.replacement.Font.Shadow = False
With Selection.Find
.Text = ""
.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
' kazakh language
Selection.WholeStory
Selection.LanguageID = WdLanguageID.wdKazakh
Application.CheckLanguage = False
Selection.Collapse Direction:=wdCollapseStart
End Sub
I set a user Find+Replace All macro, to find and replace all instances of a particular text, and it worked as planned.
However when I recorded that operation as a macro, and ran it, it replaced just the first instance of the find text. What am I doing wrong?
The code that was recorded is a further below.
Sub Macro25()
'
' Macro25 Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Body Text")
With Selection.Find.ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorBlack
.BackgroundPatternColor = wdColorBlack
End With
.Borders.Shadow = False
End With
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Body Text 2")
With Selection.Find.Replacement.ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorBlack
.BackgroundPatternColor = wdColorBlack
End With
.Borders.Shadow = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
The macro is only replacing the text that you have selected when you run the macro. That's what the word Selection means.
If you want the Find/Replace to happen for your whole document, you need to replace Selection in your macro with ActiveDocument.
Thanks for the answer.
So moving on here ... below is the code I wrote myself. It is based on the code produced by the Macro recorder.
My code does not use the same idea of Selection. It uses a rng Range object.
However I get the same effect: that it is finding only the first instance of something.
Function ExecReplaceStyle(strSourceStyle As String, strDestinationStyle As String) As Integer
On Error GoTo ErrorHandler
Dim rng As Range
Dim ret As Integer
ExecReplaceStyle = 0
Set rng = docActiveDoc.Range
With rng.Find
.ClearFormatting
.Style = ActiveDocument.Styles(strSourceStyle)
.Replacement.Style = ActiveDocument.Styles(strDestinationStyle)
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
rng.Select
rng.Find.Execute Replace:=wdReplaceAll
ExecReplaceStyle = ret
Exit Function
ErrorHandler:
ExecReplaceStyle = Err.Number
ErrDescription = Err.Description
Resume Next
End Function
The Selection.Find.Execute Replace:=wdReplaceAll after the End With should search and replace across the whole document.