Duplicate Line and Replace word

Hello, I have a file that has a sentence on one row and a second tab with find/replace words. I am hoping through VBA or something similar I could run a tool that would review my file (approx 50,000 lines) and if the word in Column 1 is present, it would duplicate the row x times, depending on how many replace words there are and change the word in the sentence. Attached is a very simple sample file of what I am trying to accomplish.

Example:
Sheet 1: The Cat jumped over the Dog

Sheet 2:
Find / Replace With
Dog / Frog
Dog / Turtle
Dog / Pig
Dog / Horse

Sheet 3:
The Cat jumped over the Dog
The Cat jumped over the Frog
The Cat jumped over the Turtle
The Cat jumped over the Pig
The Cat jumped over the Horse

Thanks for any help you can offer!

This is awesome, I forgot one detail. On the "Starting Point" tab there are two columns. Column A has the Sentence and Column B has the persons Name. I need column B (The name) to be included on the new file/lines. Updated sample attached.

Thanks!!

Also, this only applies to the first row, however, my source Starting Point is 50,000 rows. Can it be expanded to include all 50,000 rows on the starting point tab?

Try

Please Login or Register  to view this content.

Thanks for trying. Unfortunately, this didn't work. I am getting a Run-Time Error 1004.

Sub test()
Dim a, b, c, i As Long, ii As Long, n As Long
a = Sheets("starting point").[a1].CurrentRegion.Value
b = Sheets("Replace word List").[a1].CurrentRegion.Value
ReDim c(1 To UBound(a, 1) * UBound(b, 1), 1 To 4)
For i = 1 To UBound(a, 1)
For ii = 1 To UBound(b, 1)
n = n + 1: c(n, 4) = a(i, 2)
c(n, 1) = Replace(a(i, 1), b(ii, 1), b(ii, 2))
Next ii, i
Sheets("end result").[a1].Resize(n, 4) = c <--- log shows issue is here
End Sub

Originally Posted by bebo021999

Alternative:

PHP Code: 

Option Explicit
Sub replaceSP()
Dim lr&, i&, j&, k&, star, rep, res(1 To 10000, 1 To 2)
With Sheets("Starting Point")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    star = .Range("A1:B" & lr).Value ' array of starting point
End With
With Sheets("Replace word List")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rep = .Range("A2:B" & lr).Value ' array of replaced word list
End With
For i = 1 To UBound(star)
    k = k + 1: res(k, 1) = star(i, 1): res(k, 2) = star(i, 2) ' save 1st original row into result array
    For j = 1 To UBound(rep)
        If InStr(1, star(i, 1), rep(j, 1)) Then ' if found
            k = k + 1: res(k, 1) = Replace(star(i, 1), rep(j, 1), rep(j, 2)) ' replace then save to result array
            res(k, 2) = star(i, 2)
        End If
    Next
Next
With Sheets("End Result")
    .Range("A1").Resize(k, 2).Value = res ' copy result array to sheet
End With
End Sub 


Thanks for this suggestion unfortunately when I run it I am getting a Run Time Error 9 and the debug is highlighting this line:
k = k + 1: res(k, 1) = Replace(star(i, 1), rep(j, 1), rep(j, 2)) ' replace then save to result array

Try

Please Login or Register  to view this content.