Conditional_Replacing

Bikram · #1 12-28-2021, 09:51 PM

Hello, I am using find and replace and it seems to work fine but I need to modify it. Here is the code.

Code:

Sub findMm()
Dim strfind() As Variant
Dim strreplace() As Variant
Dim i As Integer
    strfind = Array("A", "An", "The", "To", "With" )
    strreplace = Array("a", "an", "the", "to","with")
    For i = 0 To UBound(strfind)
        With Selection.find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = strfind(i)
            .Format = True
            .Forward = True
            .MatchWildcards = False
            .MatchCase = True
            .Replacement.Text = strreplace(i)
            .Execute Replace:=wdReplaceAll
        End With
    Next i
End Sub

What I want to do here is to replace the found items only if they are in the middle of the sentences and ignore them if they are at the beginning of the sentences.

For Example:

To Find The Answer Of The Question.
With The Help Of People.

Replace the text except for the first word

To Find the Answer to the Question.
With the help of People.

How can it be done?? Thanks in advance.

gmayor · #2 12-28-2021, 10:16 PM

The following should work, however I suspect you may be converting to true title case in which case see VBA Code Examples (2)

Code:

Sub findMm()
Dim oRng As Range
Dim strfind() As Variant
Dim strreplace() As Variant
Dim i As Integer
    strfind = Array("A", "An", "The", "To", "With")
    strreplace = Array("a", "an", "the", "to", "with")
    For i = 0 To UBound(strfind)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = strfind(i)
            .Format = True
            .Forward = True
            .MatchWildcards = False
            .MatchCase = True
            .MatchWholeWord = True
            Do While .Execute
                If Not oRng.Start = oRng.Sentences(1).Start Then
                    oRng.Text = strreplace(i)
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
    Set oRng = Nothing
End Sub

Bikram · #3 12-28-2021, 11:05 PM

Thanks, Boss!!

Bikram · #4 01-08-2022, 11:18 PM

Sorry to bother you again sir, But I am facing some difficulties to implement these solutions that you provided on your website for Truetitlecase

Code:

Option Explicit

Sub TrueTitleCase()
Dim sText As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long
Dim m As Long
    Set sText = Selection.Range
    'count the characters in the selected string
        k = Len(sText)
        If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub 'and quit the macro
        End If
    'format the selected string as title case
    sText.Case = wdTitleWord
    'list the exceptions to look for in an array
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
    "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
    "if", "in", "of", "on", "or", "the", "to", "with")
    With sText
        With .Find
        'replace items in the first list
        'with the corresponding items from the second
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Format = True
        .MatchCase = True
        For i = LBound(vFindText) To UBound(vFindText)
        .Text = vFindText(i)
        .Replacement.Text = vReplText(i)
        .Execute Replace:=wdReplaceAll
        Next i
    End With
    'Reduce the range of the selected text
    'to encompass only the first character
    .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
    'format that character as upper case
    .Case = wdUpperCase
    'restore the selected text to its original length
    .MoveEnd Unit:=wdCharacter, Count:=k
    'and check to see if the string contains a colon
    If InStr(1, sText, ":") > 0 Then
    'If it does note the position of the character
    'after the first colon
    m = InStr(1, sText, ":") + 1
    'and set that as the new start of the selected text
    .MoveStart wdCharacter, m
    'set the end of the selected text to include
    'one extra character
    .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
    'format that character as upper case
    .Case = wdUpperCase
    End If
    End With
    lbl_Exit:
    Exit Sub
    End Sub

I tried to modify this code to find and replace all vFindText(i) except the first word in "selection.range. If not stext.range.start = stext.range.sentences(1)" does not seem to work reliably. Can you please modify your code to meet my need?

gmayor · #5 01-11-2022, 02:13 AM

If I understand correctly, you wish to capitalize the character following a colon in the selection? In that case:

Code:

Sub TrueTitleCase()
Dim rSel As Range, oRng As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long

    Set oRng = Selection.Range
    Set rSel = Selection.Range
    'count the characters in the selected string
    k = Len(rSel)
    If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub    'and quit the macro
    End If
    'format the selected string as title case
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")
    With rSel
        .Case = wdTitleWord
        'list the exceptions to look for in an array
        With .Find
            'replace items in the first list
            'with the corresponding items from the second
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = True
            .MatchCase = True
            For i = LBound(vFindText) To UBound(vFindText)
                .Text = vFindText(i)
                .Replacement.Text = vReplText(i)
                .Execute Replace:=wdReplaceAll
            Next i
        End With
    End With
    FixColon oRng
lbl_Exit:
    Set rSel = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Sub FixColon(oRng As Range)
Const sList As String = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim rSel As Range
    oRng.Select
    Set rSel = Selection.Range
    With rSel.Find
        .Text = ":"
        Do While .Execute
            If rSel.InRange(oRng) = False Then Exit Do
            rSel.MoveStartUntil sList
            rSel.Characters(1).Case = wdUpperCase
            rSel.Collapse 0
        Loop
    End With
    oRng.Select
lbl_Exit:
    Exit Sub
End Sub

Bikram · #6 01-11-2022, 05:46 AM

Thanks for the reply sir. And also sorry if I had failed to make you understand my situation. I have to work on word documents where I encounter these types of conditions:
I use to select the words till ":" by looping through every paragraph and using following code

Code:

    With Selection
        .MoveLeft Unit:=wdWord, Count:=1
        .MoveRight Unit:=wdWord, Count:=3
        .StartIsActive = False
        .Extend Character:=":"
    If Selection.Range.Bold = True Then
        TrueTitleCase
    End If
        .Collapse
    End With

a. say's law in the barter economy: In barter economy, goods are produced either
b. it say's law in money economy: In the money economy, products are sold
c. if say's law in money economy: In the money economy, products are sold
d. the say's law in money economy: In the money economy, products are
e. on say's law in money economy: In the money economy, products are
f. a say's law in money economy: In the money economy, products are sold sold

This is just the sample text what happens here, the code changes all the selection word to wdtitle case. Everything is fine till here now I just want to ignore the first word of the selection (For example If ("The","If","On") etc. If Vfindtext(i) is in the first word of the sentence then ignore it. If it is in other places (except the first word of selection) Then replace it like:
a. Say's Law in the Barter Economy: In barter economy, goods are produced either
b. It Say's Law in Money Economy: In the money economy, products are sold
c. If Say's Law in Money Economy: In the money economy, products are sold
d. The Say's Law in Money Economy: In the money economy, products are
e. On Say's Law in Money Economy: In the money economy, products are
f. A Say's Law in Money Economy: In the money economy, products are sold
Thank you for your help.

gmayor · #7 01-11-2022, 10:21 PM

Based on your example, the following should work with selected paragraphs:

Code:

Sub FormatPara()
Dim oPara As Paragraph
Dim oRng As Range
    For Each oPara In Selection.Paragraphs
        Set oRng = oPara.Range
        oRng.End = oRng.End - 1
        If oRng.Characters(2) = "." Then
            oRng.MoveStart 2
        End If
        If InStr(1, oPara.Range.Text, ":") > 0 Then
            oRng.Collapse 1
            oRng.MoveEndUntil ":"
        End If
        TrueTitleCase oRng
    Next oPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Sub TrueTitleCase(oRng As Range)
Dim rSel As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long

    Set rSel = oRng
    'count the characters in the selected string
    k = Len(rSel)
    If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub    'and quit the macro
    End If
    'format the selected string as title case
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")
    With rSel
        .Case = wdTitleWord
        'list the exceptions to look for in an array
        With .Find
            'replace items in the first list
            'with the corresponding items from the second
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = True
            .MatchCase = True
            For i = LBound(vFindText) To UBound(vFindText)
                .Text = vFindText(i)
                .Replacement.Text = vReplText(i)
                .Execute Replace:=wdReplaceAll
            Next i
        End With
    End With
lbl_Exit:
    Set rSel = Nothing
    Exit Sub
End Sub

Bikram · #8 01-11-2022, 11:00 PM

Sorry to say this sir, But it still failed to address my problem. What the code should be able to do is, if first word of the selection is in vfindtext(i) then just ignore it and replace all from the second word. For example, many sentences start from To, The, A, An etc. which are listed in vfindtext array I don't want to replace them if they are in the starting position of range or sentences Else replace them. The above code works excellent just fails to address this problem.

gmayor · #9 01-12-2022, 12:02 AM

The following adopts a slightly different approach. Change the first macro to

Code:

Sub FormatPara()
Dim oPara As Paragraph
Dim oRng As Range
    For Each oPara In Selection.Paragraphs
        Set oRng = oPara.Range
        oRng.End = oRng.End - 1
        If Len(oRng) > 2 Then
            If oRng.Characters(2) = "." Then
                oRng.MoveStart 3
                oRng.MoveStartWhile Chr(9)
                oRng.MoveStartWhile Chr(32)
                oRng.MoveStartWhile Chr(160)
            End If
            If InStr(1, oPara.Range.Text, ":") > 0 Then
                oRng.Collapse 1
                oRng.MoveEndUntil ":"
            End If
            TrueTitleCase oRng
            oRng.Characters(1).Case = wdUpperCase
        End If
    Next oPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Bikram · #10 01-13-2022, 03:25 AM

Thank you, boss. With little modification, it perfectly meets my needs.