macro to find and replace the case of different characters in a two-column table

Anonymous
2016-06-24T10:32:23+00:00

Hi team,

Currently I am working with this macro

Sub ReplaceFromTableList()

Dim oChanges As Document, oDoc As Document

Dim oTable As Table

Dim oRng As Range

Dim rFindText As Range, rReplacement As Range

Dim i As Long

Dim sFname As String

Dim sAsk As String

    sFname = "C:\Users\Win7\Desktop\macro.docx" 'The table document

    Set oDoc = ActiveDocument

    Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)

    Set oTable = oChanges.Tables(1)

    For i = 1 To oTable.Rows.Count

        Set oRng = oDoc.Range

        Set rFindText = oTable.Cell(i, 1).Range

        rFindText.End = rFindText.End - 1

        Set rReplacement = oTable.Cell(i, 2).Range

        rReplacement.End = rReplacement.End - 1

        With oRng.Find

        .ClearFormatting

        .Replacement.ClearFormatting

        .Execute FindText:=rFindText.Text, _

                 MatchWildcards:=True, _

                 ReplaceWith:=rReplacement.Text, _

                 Replace:=wdReplaceAll

    End With           

    Next i

    oChanges.Close wdDoNotSaveChanges

lbl_Exit:

    Exit Sub

End Sub

This macro finds terms in the first column of a table and replaces them by those on the second column, and it enables you to use wildcards as follows

([Hh])owever \1wv.
<([Aa])s well as> \1wa.

Yet, in some pairs the first character of the first column is not the same as the first one of the second column, as in

expression xprss.

Therefore, I have two questions, namely

a) whether it is possible to use wildcards to somehow carry out an operation which would transmit the upper/lower case of the first character of the first column into the first character of the second column, so that both coincide

b) whether, if such an operation is not possible using wildcards, the macro I am working with (or even a completely different one) could be modified so that my purpose can be succesfully achieved.

I'd very much appreciate any ideas on the alternatives I have.

Microsoft 365 and Office | Word | For home | Windows

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments
Answer accepted by question author
Doug Robbins - MVP - Office Apps and Services 323.6K Reputation points MVP Volunteer Moderator
2016-07-03T00:54:16+00:00

In that case, use:

With Sheets(1).Range("A1")

    For i = 0 To .CurrentRegion.Rows.Count

        For k = 0 To 1

            For j = 1 To .Offset(i, k).Characters.Count

                If IsNumeric(Left(.Offset(i, k), 1)) Then

                    GoTo Nextj

                End If

                If Asc(Left(.Offset(i, k), 1)) > 64 And Asc(Left(.Offset(i, k), 1)) < 90 Then

                    GoTo Nextj

                End If

                If Asc(Mid(.Offset(i, k), j, 1)) > 96 And Asc(Mid(.Offset(i, k), j, 1)) < 123 Then

                    .Offset(i, k) = Left(.Offset(i, k), j - 1) & UCase(Mid(.Offset(i, k), j, 1)) & Mid(.Offset(i, k), j + 1)

                    Exit For

                End If

Nextj:

            Next j

        Next k

     Next i

End With

Was this answer helpful?

0 comments
Answer accepted by question author
Paul Edstein 82,871 Reputation points Volunteer Moderator
2016-06-26T02:05:53+00:00

I've made some minor revisions to the previous code, so both macros should now run without error.

Regarding the formatting, unless you use a 4-column table, there's really no reliable way of knowing whether the formats found in the cells are important to the Find/Replace operation. How would one tell, for example, whether the absence of a bold font means the content to be found is not to be bolded, or that bolding is inconsequential? Separate columns to designate the applicability of font attributes for both the Find and the Replace would be required. the following macro envisages such a table, where the presence of content in the 3rd & 4th columns dictate whether the font format is to be taken into account for the Find (column 3) or applied to the Replace (column 4); if the cell has content, the formatting there is applied to the Find and/or Replace, as applicable.

Sub ReplaceFromTableList()

Application.ScreenUpdating = False

Dim Doc As Document, Rng As Range, i As Long, Tbl As Table

Dim sFname As String, StrFnd As String, StrRep As String

sFname = "C:\Users\Win7\Desktop\macro.docx" 'The table document

Set Rng = ActiveDocument.Range

Set Doc = Documents.Open(FileName:=sFname, Visible:=False)

Set Tbl = Doc.Tables(1)

With Rng.Find

  .MatchWildcards = True

  .Wrap = wdFindContinue

  For i = 1 To Tbl.Rows.Count

    .ClearFormatting

    .Replacement.ClearFormatting

    StrFnd = Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0)

    StrRep = Split(Tbl.Cell(i, 2).Range.Text, vbCr)(0)

    .Text = StrFnd

    .Replacement.Text = StrRep

    If Split(Tbl.Cell(i, 3).Range.Text, vbCr)(0) <> "" Then

      Set FntFnd = Tbl.Cell(i, 4).Range.Characters(1).Font

      .Font.Bold = FntFnd.Bold

      .Font.Italic = FntFnd.Italic

      .Font.Underline = FntFnd.Underline

    End If

    If Split(Tbl.Cell(i, 4).Range.Text, vbCr)(0) <> "" Then

      Set FntRep = Tbl.Cell(i, 4).Range.Characters(1).Font

      With .Replacement

        .Font.Bold = FntRep.Bold

        .Font.Italic = FntRep.Italic

        .Font.Underline = FntRep.Underline

      End With

    End If

    .Execute Replace:=wdReplaceAll

    .Text = LCase(StrFnd)

    .Replacement.Text = LCase(StrRep)

    .Execute Replace:=wdReplaceAll

  Next i

End With

Doc.Close wdDoNotSaveChanges

Application.ScreenUpdating = True

End Sub

Was this answer helpful?

0 comments

46 additional answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2016-06-25T00:00:01+00:00

    If you construct your table as:

    However Hwv.
    <As well as> Awa.
    Expression Xprss.

    you could use a macro like:

    Sub ReplaceFromTableList()

    Application.ScreenUpdating = False

    Dim Doc As Document, Rng As Range, i As Long, Tbl As Table

    Dim sFname As String, StrFnd As String, StrRep As String

    sFname = "C:\Users\Win7\Desktop\macro.docx" 'The table document

    Set Rng = ActiveDocument.Range

    Set Doc = Documents.Open(FileName:=sFname, Visible:=False)

    Set Tbl = Doc.Tables(1)

    With Rng.Find

      .ClearFormatting

      .Replacement.ClearFormatting

      .MatchWildcards = True

      .Wrap = wdFindContinue

      For i = 1 To Tbl.Rows.Count

        StrFnd = Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0)

        StrRep = Split(Tbl.Cell(i, 2).Range.Text, vbCr)(0)

        .Text = StrFnd

        .Replacement.Text = StrRep

        .Execute Replace:=wdReplaceAll

        .Text = LCase(StrFnd)

        .Replacement.Text = LCase(StrRep)

        .Execute Replace:=wdReplaceAll

      Next i

    End With

    Doc.Close wdDoNotSaveChanges

    Application.ScreenUpdating = True

    End Sub

    The above code doesn't do anything regarding the text formatting. If you want to modify the font attributes, you could use code like:

    Sub ReplaceFromTableList()

    Application.ScreenUpdating = False

    Dim Doc As Document, Rng As Range, i As Long, Tbl As Table

    Dim sFname As String, StrFnd As String, StrRep As String

    sFname = "C:\Users\Win7\Desktop\macro.docx" 'The table document

    Set Rng = ActiveDocument.Range

    Set Doc = Documents.Open(FileName:=sFname, Visible:=False)

    Set Tbl = Doc.Tables(1)

    With Rng.Find

      .ClearFormatting

      .Replacement.ClearFormatting

      .MatchWildcards = True

      .Wrap = wdFindContinue

      For i = 1 To Tbl.Rows.Count

        StrFnd = Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0)

        StrRep = Split(Tbl.Cell(i, 2).Range.Text, vbCr)(0)

        Set FntFnd = Tbl.Cell(i, 1).Range.Characters(1).Font

        Set FntRep = Tbl.Cell(i, 2).Range.Characters(1).Font

        .Text = StrFnd

        .Font.Bold = FntFnd.Bold

        .Replacement.Font.Bold = FntRep.Bold

        .Font.Italic = FntFnd.Italic

        .Replacement.Font.Italic = FntRep.Italic

        .Font.Underline = FntFnd.Underline

        .Replacement.Font.Underline = FntRep.Underline

        .Replacement.Text = StrRep

        .Execute Replace:=wdReplaceAll

        .Text = LCase(StrFnd)

        .Replacement.Text = LCase(StrRep)

        .Execute Replace:=wdReplaceAll

      Next i

    End With

    Doc.Close wdDoNotSaveChanges

    Application.ScreenUpdating = True

    End Sub

    The above shows how you could limit the Find the particular font attributes and apply particular font attributes to the replacement. You can, of course, use either without the other.

    Was this answer helpful?

    0 comments
  2. Anonymous
    2016-06-24T14:06:18+00:00

    Thanks for replying so fast Paul,

    I'd like to know the exact procedure by which using your new macro and two F/R expressions I can finally achieve my goal.

    The problem with the macro I posted is that originally the macro had this part

    With oRng.Find

                .ClearFormatting

                .Replacement.ClearFormatting

                Do While .Execute(FindText:=rFindText, _

                      MatchCase:=True, _

                      MatchWholeWord:=True, _

                      MatchWildcards:=True, _

                      Forward:=True, _

                      Wrap:=wdFindStop) = True

        oRng.Select

        'oRng.FormattedText = rReplacement.FormattedText

        oRng.Text = rReplacement.Text

        oRng.Collapse wdCollapseEnd

    Loop

            End With

    and to include alternative formatting, I could format the text in the second column as I wanted it to appear and move the apostrophe from the start of the first of the following lines and add it to the start of the second. i.e. change

    'oRng.FormattedText = rReplacement.FormattedText

    oRng.Text = rReplacement.Text

    to

    oRng.FormattedText = rReplacement.FormattedText

    'oRng.Text = rReplacement.Text

    But in order to use the wildcard operation

    F: ([Xx])

    R: \1 

    that ‘chunk’ of the macro was changed into

    With oRng.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            .Execute FindText:=rFindText.Text, _

                     MatchWildcards:=True, _

                     ReplaceWith:=rReplacement.Text, _

                     Replace:=wdReplaceAll

        End With

    Therefore, I no longer know how to include the previous possibility of change in the formatting, which I indeed need.

    Was this answer helpful?

    0 comments
  3. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2016-06-24T13:38:54+00:00

    In such cases the better course would be to use two F/R expressions. While code could be written to do what you want, it would slow down every F/R and add a lot of complexity for relatively little return.

    PS: Your current macro could be reduced to:

    Sub ReplaceFromTableList()

    Application.ScreenUpdating = False

    Dim Doc As Document, Rng As Range, i As Long, sFname As String

    sFname = "C:\Users\Win7\Desktop\macro.docx" 'The table document

    Set Rng = ActiveDocument.Range

    Set Doc = Documents.Open(FileName:=sFname, Visible:=False)

    With Rng.Find

      .ClearFormatting

      .Replacement.ClearFormatting

      .MatchWildcards = True

      .Wrap = wdFindContinue

      For i = 1 To Doc.Tables(1).Rows.Count

        .Text = Split(oTable.Cell(i, 1).Range.Text, vbCr)(0)

        .Replacement.Text = Split(oTable.Cell(i, 2).Range.Text, vbCr)(0)

        .Execute Replace:=wdReplaceAll

      Next i

    End With

    oChanges.Close wdDoNotSaveChanges

    Application.ScreenUpdating = True

    End Sub

    The above code will also be faster and more efficient.

    Was this answer helpful?

    0 comments