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: Newest
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. Anonymous
    2016-12-06T17:09:17+00:00

    This is version is great -- it works perfectly!

    Was this answer helpful?

    0 comments
  3. Anonymous
    2016-11-18T20:45:22+00:00

    Has anyone created a macro that would simply recreate Word's "auto-correct" function for text that already exists? Basically do a search and replace for every auto-correct entry?

    Was this answer helpful?

    0 comments
  4. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2016-09-13T21:32:10+00:00

    See my reply in your other thread (http://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-mso_win10/macro-for-editing-acronyms/46d7b361-a8d5-4cf2-b0dd-f10c45ab3034). If required, the macro I've posted there could be modified to process only acronyms in a pre-defined list, without the Find itself having to loop through an array of such terms.

    Was this answer helpful?

    0 comments