Create fill-in-the-blank sentences with xl

[HowdeeDoodee]

I need a macro that creates a series of fill-in-the-blank sentences or tests. The sentences without blanks are in column A. The sentences with blanks would appear in column B. The words to be blanked out in column B (replaced with an underscore line) are in column C. The rules to replace the words in the sentences in column B are as follows:

Rules:

1. Replace words in the sentences using the delete list.
2. Replace words in the sentence from left to right.
3. Replace only one word from the sentence every time the macro is run.

The macro is to be run one time creating one underscore line or blank in each sentence in column B where a delete word appears. Then the macro is to be run a second time creating another underscore line or blank in each sentence where a delete word appears. Then the macro is to be run a third time creating another underscore line or blank in each sentence where a delete word appears, and so on until I chose to not run the macro any more. If a delete word appears more than once in a sentence, only the first occurrence of the delete word is taken out until another run of the macro is made because only one word is deleted from each sentence every time the macro is run.

The sentences with words deleted would appear in column B.

Every time the macro is run, I will copy the result from column B to another sheet to store the result.

Here are before and after examples.

Before: (These sentences appear in column A.)

The cat danced all night.
The cat ate the dog's food.
The dog and the frog played the piano.
The frog and the cat jumped over the fence.
The fox ate the frog and got sick.
The cat ate a candy bar and the cat got sick.

After: In column B, macro run once results in…

The ___ danced all night.
The ___ ate the dog's food.
The ___ and the frog played the piano.
The ___ and the cat jumped over the fence.
The ___ ate the frog and got sick.
The ___ ate a candy bar and the cat got sick.

After: In column B, macro run twice results in…

The ___ ___ all night.
The ___ ___ the dog's food.
The ___ and the ___ played the piano.
The ___ and the ___ jumped over the fence.
The ___ ate the ___ and got sick.
The ___ ___ a candy bar and the cat got sick.

After: In column B, macro run three times results in…

The ___ ___ all ___.
The ___ ___ the ___'s food.
The ___ and the ___ played the ___.
The ___ and the ___ ___ over the fence.
The ___ ate the ___ and got ___.
The ___ ___ a ___ bar and the cat got sick.

After: In column B, macro run four times results in…

The ___ ___ all ___.
The ___ ___ the ___'s food.
The ___ and the ___ played the ___.
The ___ and the ___ ___ over the ___.
The ___ ate the ___ and got ___.
The ___ ___ a ____ bar and the ___ got sick.

Delete List In Column C (these are the words to be blanked out with an underscore line)

Cat
Danced
Night
Candy
Ate
Dog
Food
Frog
Piano
Jumped
Fence
Fox
Sick


Thank you in advance for any replies. Your help is appreciated.

 

[jindon]

Hope this works for you

Sub test()
Dim r As Range, m As Object, e, myList, txt As String, flg As Boolean
myList = Range("c1",Range("c" & Rows.Count).End(xlUp)).Value
For Each r In Range("a1",Range("a" & Rows.Count).End(xlUp))
    txt = r.Value
    If Len(txt) Then
        With CreateObject("VBScript.RegExp")
            .Pattern = "\S+"
            .Global = True
            For Each m In .execute(txt)
                For Each e In myList
                    If StrComp(m.Value,e,1) = 0 Then
                        r.Offset(,1).Value = WorksheetFunction.Substitute(txt,e,String(m.Length,"_"),1)
                        flg = True : Exit For
                    End If
                Next
                If flg Then flg = False : Exit For
            Next
        End With
    End If
Next
End Sub

 

[HowdeeDoodee]

Hi, jindon, how are you. Good to see you again.

Well, I tried out the code and on my system, pasting in the code the way it came to me, all I got in column B was a direct copy of what is in column A. There were no blanks in column B. Any ideas? Thank you for the post.

 

[jindon]

Good see you again, too.
Not sure why it does such
How about?

Sub test()
Dim r As Range, m As Object, e, myList, txt As String, flg As Boolean
myList = Range("c1",Range("c" & Rows.Count).End(xlUp)).Value
For Each r In Range("a1",Range("a" & Rows.Count).End(xlUp))
    txt = r.Value
    If Len(txt) Then
        With CreateObject("VBScript.RegExp")
            .Pattern = "\S+"
            .Global = True
            For Each m In .execute(txt)
                For Each e In myList
                    If StrComp(m.Value,e,1) = 0 Then
                        r.Offset(,1).Value = WorksheetFunction.Substitute(txt,m.Value,"_",1)
                        flg = True : Exit For
                    End If
                Next
                If flg Then flg = False : Exit For
            Next
        End With
    End If
Next
End Sub

 

[HowdeeDoodee]

Excellent work Jindon. Excellent work. Truly a genius at code

In the words of Elvis, thankyouverymuch, thankyou, thankyou, thankyouverymuch!

For archival purposes and for anyone who wants to use this fine code...

Remember to copy column B over to column A after every macro run.
Also remember to take the periods out of the sentence so the last word in the sentence will be replaced.

Thank you again, Jindon. Your work is appreciated.

 

[jindon]

OOps,
right!

Sub test()
Dim r As Range, m As Object, e, myList, txt As String, flg As Boolean
myList = Range("c1",Range("c" & Rows.Count).End(xlUp)).Value
For Each r In Range("a1",Range("a" & Rows.Count).End(xlUp))
    txt = r.Offset(,1).Value
    If Not Len(txt) Then txt = r.Value
    If Len(txt) Then
        With CreateObject("VBScript.RegExp")
            .Pattern = "\S+"
            .Global = True
            For Each m In .execute(txt)
                For Each e In myList
                    If StrComp(m.Value,e,1) = 0 Then
                        r.Offset(,1).Value = WorksheetFunction.Substitute(txt,m.Value,"_",1)
                        flg = True : Exit For
                    End If
                Next
                If flg Then flg = False : Exit For
            Next
        End With
    End If
Next
End Sub