macro for performing more than one find and replace procedure at the same time

Anonymous
2010-08-07T18:21:24+00:00

ok, i've got to about 700!! find and replace procedures for a document of TWO MILLION words so this macro could save me about 4 hours of work.

i tried to rewrite this macro so that it would work but it didn't.  can anyone help me out

Sub Macro1()

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " mit der "
.Replacement.Text = " mitder"
.Text = " mit dem "
.Replacement.Text = " mitdem"
.Text = " mit den "
.Replacement.Text = " mitden"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

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
Anonymous
2010-08-07T18:56:51+00:00

ok, i got it work, i just copied it over

Sub Macro1()

'

' Macro1 Macro

' Macro recorded 8/7/10 by Seely Foley

'

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = " mit der "

        .Replacement.Text = " mitder"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = " mit den "

        .Replacement.Text = " mitden"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Was this answer helpful?

30+ people found this answer helpful.
0 comments

53 additional answers

Sort by: Oldest
Most helpful Newest Oldest
  1. Anonymous
    2017-02-22T09:33:58+00:00

    This is really helpful to me - I've been trying to create a macro which introduced typos for literacy work.

    I have increased the number of columns on the table to 6, giving five typos for each correct spelling.  Unfortunately every time a word is replaced a new line is created -can you help?

    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 x As Integer

    'Change the path in the line below to reflect the name and path of the table document

    sFname = "C:\Users\cthom\Desktop\changes.docx"

    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

        'Create a random x between 2 and 5

    Randomize

    x = Int(5 * Rnd()) + 1

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

        rReplacement.End = rReplacement.End - 1

        With oRng.Find

               ' .ClearFormatting

               ' .Replacement.ClearFormatting

                Do While .Execute(findText:=rFindText, _

                    MatchWholeWord:=True, _

                    MatchWildcards:=False, _

                    Forward:=True, _

                    Wrap:=wdFindContinue) = True

                    Randomize

    x = Int(5 * Rnd()) + 1

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

                    oRng.Text = rReplacement

                Loop

        End With

    Next i

    oChanges.Close wdDoNotSaveChanges

    End Sub

    Was this answer helpful?

    1 person found this answer helpful.
    0 comments
  2. Doug Robbins - MVP - Office Apps and Services 323.6K Reputation points MVP Volunteer Moderator
    2017-02-22T10:20:46+00:00

    Replace

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

                    oRng.Text = rReplacement

    with

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

                    rReplacement.End = rReplacement.End - 1

                    oRng.Text = rReplacement

    Was this answer helpful?

    1 person found this answer helpful.
    0 comments
  3. Anonymous
    2017-02-22T19:32:10+00:00

    Thanks ever so much.  Solved my problem.   

    Unfortunately there's always one more thing ..

    It goes strange when I try replacing I with i (something my students do all the time), and I cannot seem to replace capital letters with lower case.

    Thanks again for your help :-)

    Chris

    Was this answer helpful?

    0 comments
  4. Doug Robbins - MVP - Office Apps and Services 323.6K Reputation points MVP Volunteer Moderator
    2017-02-22T23:20:05+00:00

    Try adding 

    MatchCase:=True

    into the code (though it may interfere with some of the other find\replacements, depending upon how they are defined.

    Of course, if the I is just one letter within a Word, it will not be found because you have  MatchWholeWord:=True

    Was this answer helpful?

    0 comments