Find phrase and erase all other words

Hello,

I am attempting to write a macro that does the following to the attached file. Does anybody know of a quick way to do this? I am seriously a beginner when it comes to VBE. Just ordered a few books on how to do this.

1. Read column A and name it the same name as the current tab.
2. Read column E and if it sees a specific Group’s name, then throw contact information found on Address Values tab onto row on first tab (I through column O). If it sees a specific Group name that it does not recognize, then move on to the next row without copying information. Repeat this step all the way down until there are no more values in column E.
3. Column U:
a. If it sees text in cell “Case Evaluation” change cell to read “Case Eval Complete”
b. If it sees text in cell “Eligibility” change cell to read “Eligibility Eval Complete”
c. If it sees text in cell “Off-Treatment” change cell to read “Off-Treatment Form”
d. If it sees text in cell “Follow-up 1” change cell to read “Follow-up 1”
e. If it sees text in cell “Follow-up 2” change cell to read “Follow-up 2”
f. If it sees text in cell “Follow-up 3” change cell to read “Follow-up 3”
4. Change data found in column W to currency.

Any help is greatly appreciated.Milestone Help.xlsx

Hello csch123,

The attached workbook does all you requested except for what is below. I think there is some information missing because the before and after results shown are the same.

d. If it sees text in cell “Follow-up 1” change cell to read “Follow-up 1”
e. If it sees text in cell “Follow-up 2” change cell to read “Follow-up 2”
f. If it sees text in cell “Follow-up 3” change cell to read “Follow-up 3”

Here is the macro code so far.

' Thread:  http://www.excelforum.com/excel-programming/838317-macro-help-needed.html
' Poster:  csch123
' Written: June 14, 2012
' Author:  Leith Ross (www.excelforum.com)

Sub Macro1A()

    Dim AddressData As Variant
    Dim AddxWks As Worksheet
    Dim GroupRng As Range
    Dim HelpGroupRng As Range
    Dim HelpWks As Worksheet
    Dim Matches As Object
    Dim InvoiceRng As Range
    Dim RegExp As Object
    Dim RngEnd As Range
    Dim RowCnt As Long
    Dim ServiceRng As Range
    Dim Text As String
    
        Set HelpWks = Worksheets("Milestone Help")
        Set AddxWks = Worksheets("Address Values")
        
        Set InvoiceRng = Names("Invoices").RefersToRange
        Set GroupRng = Names("Group").RefersToRange
        Set HelpGroupRng = HelpWks.Range("E2")
            
            Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.IgnoreCase = True

            Set RngEnd = HelpWks.Cells(Rows.Count, InvoiceRng.Column).End(xlUp)
            If RngEnd.Row < InvoiceRng.Row Then Exit Sub
            
            Set InvoiceRng = InvoiceRng.Resize(RowSize:=RngEnd.Row - InvoiceRng.Row + 1)
            Set GroupRng = GroupRng.Resize(RowSize:=InvoiceRng.Rows.Count)
            
              ' Set Column "W" to US currency format.
                HelpWks.Range("W1").EntireColumn.NumberFormat = "$#,##0.00"
            
                For Each Cell In HelpGroupRng.Resize(RowSize:=InvoiceRng.Rows.Count)
                    FoundIt = Application.Match(Cell, GroupRng, 0)
                
                  ' Copy the Address data if the Group and Invoice exist.
                    If VarType(FoundIt) <> vbError And Cell.Offset(0, -4) <> "" Then
                        AddressData = GroupRng.Rows(FoundIt).Offset(0, 1).Resize(1, 7).Value
                        Cell.Offset(0, 4).Resize(1, 7).Value = AddressData
                    End If
                    
                  ' Service Performed is in Column "U".
                    Set ServiceRng = Cell.Offset(0, 16)
                    
                  ' Check if Service Performed requires any changes.
                    Text = ServiceRng.Value
                    
                    RegExp.Pattern = "\b(Treatment)\s+(\w+)\b"
                    
                  ' Insert "Form" after "Treatment" if needed.
                    If RegExp.Test(Text) = True Then
                        Set Matches = RegExp.Execute(Text)
                        If LCase(Matches(0).SubMatches(1)) <> "form" Then
                            ServiceRng.Value = RegExp.Replace(Text, "$1" & " Form " & "$2")
                        End If
                    End If
                    
                    RegExp.Pattern = "\b(Case|Eligibility)\s+(Evaluation)\b"
                    
                  ' Change "Evaluation" to "Eval" if needed.
                    If RegExp.Test(Text) = True Then
                        Set Matches = RegExp.Execute(Text)
                        ServiceRng.Value = RegExp.Replace(Text, "$1" & " Eval ")
                    End If
                    
                Next Cell
        
End Sub

Hi Csch,

Your post does not comply with Rule 1 of our Forum RULES. Your post title should accurately and concisely describe your problem, not your anticipated solution. Use terms appropriate to a Google search. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will be addressed according to the OP's experience in the forum: If you have less than 10 posts, expect (and respond to) a request to change your thread title. If you have 10 or more posts, expect your post to be locked, so you can start a new thread with an appropriate title.

To change a Title on your post, click EDIT POST in your first post in the thread, then click Go Advanced and change your title, if 2 days have passed ask a moderator to do it for you.

Hello csch123,

Here is an update version of the macro. If any phrase you mentioned above is found in column "U", it will be changed to the replacement phrase.

' Thread:  http://www.excelforum.com/excel-programming/838317-macro-help-needed.html
' Poster:  csch12
' Written: June 14, 2012
' Updated: June 18, 2012
' Author:  Leith Ross (www.excelforum.com)

Sub Macro1B()

    Dim AddressData As Variant
    Dim AddxWks As Worksheet
    Dim GroupRng As Range
    Dim HelpGroupRng As Range
    Dim HelpWks As Worksheet
    Dim i As Integer
    Dim InvoiceRng As Range
    Dim Phrase As Variant
    Dim Phrases(1 To 6, 1 To 2) As Variant
    Dim RngEnd As Range
    Dim RowCnt As Long
    Dim ServiceRng As Range
    Dim Text As String
    
        Set HelpWks = Worksheets("Milestone Help")
        Set AddxWks = Worksheets("Address Values")
        
        Set InvoiceRng = Names("Invoices").RefersToRange
        Set GroupRng = Names("Group").RefersToRange
        Set HelpGroupRng = HelpWks.Range("E2")
            
            Set RngEnd = HelpWks.Cells(Rows.Count, InvoiceRng.Column).End(xlUp)
            If RngEnd.Row < InvoiceRng.Row Then Exit Sub
            
            Set InvoiceRng = InvoiceRng.Resize(RowSize:=RngEnd.Row - InvoiceRng.Row + 1)
            Set GroupRng = GroupRng.Resize(RowSize:=InvoiceRng.Rows.Count)
            
          ' Search for these phrases   ----->   Replace with these phrases
            Phrases(1, 1) = "*Case*Evaluation*":  Phrases(1, 2) = "Case Eval Complete"
            Phrases(2, 1) = "*Eligibility*":      Phrases(2, 2) = "Eligibilty Eval Complete"
            Phrases(3, 1) = "*Off-Treatment*":    Phrases(3, 2) = "Off-Treatment Form"
            Phrases(4, 1) = "*Follow-up 1*":      Phrases(4, 2) = "Follow-up 1"
            Phrases(5, 1) = "*Follow-up 2*":      Phrases(5, 2) = "Follow-up 2"
            Phrases(6, 1) = "*Follow-up 3*":      Phrases(6, 2) = "Follow-up 3"
              
              ' Set Column "W" to US currency format.
                HelpWks.Range("W1").EntireColumn.NumberFormat = "$#,##0.00"
            
                For Each Cell In HelpGroupRng.Resize(RowSize:=InvoiceRng.Rows.Count)
                    FoundIt = Application.Match(Cell, GroupRng, 0)
                
                  ' Copy the Address data if the Group and Invoice exist.
                    If VarType(FoundIt) <> vbError And Cell.Offset(0, -4) <> "" Then
                        AddressData = GroupRng.Rows(FoundIt).Offset(0, 1).Resize(1, 7).Value
                        Cell.Offset(0, 4).Resize(1, 7).Value = AddressData
                    End If
                    
                  ' Service Performed is in Column "U".
                    Set ServiceRng = Cell.Offset(0, 16)
                    
                  ' Check if Service Performed requires any changes.
                    Text = ServiceRng.Value

                    For i = 1 To UBound(Phrases)
                        If LCase(Text) Like LCase(Phrases(i, 1)) Then
                            ServiceRng.Value = Phrases(i, 2)
                            Exit For
                        End If
                    Next i
                    
                Next Cell
        
End Sub