How can I work around the Find(what:=) character l

问题:

I just released an Excel Add-In in my department today that I've been working on for the last 2+ months that checks for about 30 validation errors. I have the error trapping handled in all situations (as it appears right now), but I received a horrible wake-up call today as I received automatic emails (a feature I built into the error handling) for two vital bugs. The first of which is below, the second I will post separately.

The first bug has to do with the .Find what:= character limitation

The Sub that is throwing this error is as follows

'Converts Upcharge columns to all uppercase as a safety protocol,
'Checks for colons in option names and removes them from the Option Name column and in the
'upcharge columns if any upcharges correspond to that option name for the particular product.
Private Sub colOpNaCheck()
On Error GoTo ErrHandler
Application.StatusBar = "(11/16) Checking option names for colons"

    Dim rng As Range, aCell As Range, uRng1 As Range, uRng2 As Range, uCell As Range, tempC As Range
    Dim endRange As Long
    Dim opName As String, opName2 As String
    Dim xid As String

    endRange = ActiveSheet.Range("A" & Rows.count).End(xlUp).Row

    Set rng = ActiveSheet.Range("W1:W" & endRange)

    Set aCell = rng.Find(What:=":", LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        'Add colon to beginning and end of string to ensure we only find and replace the right
        'portion over in upcharge column
        opName = ":" & aCell.Value & ":"
        'Correct the value in column W
        aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "")
        'Set corrected value (sans-colon) to opName2 and add colon to beginning and
        'end of string
        opName2 = ":" & aCell.Value & ":"
        'Note the XID of the current row so we can ensure we look for the right upcharge
        xid = ActiveSheet.Range("A" & aCell.Row).Value
        'We have the option name and the xid associated with it
        'Now we have to do a find in the upcharges column to see if we find the opName
        'Then we do an if statement and only execute if the the Column A XID value matches
        'the current xid value we have now
        Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange)
        Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange)

        'Convert uRng1 & uRng2 to all uppercase just to make sure they will be detected when using Find
        ActiveSheet.Range(uRng1, uRng2).Select
        For Each tempC In Selection
            'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase
            'AND Row is not 1. All of these checks help us save on processing time
            If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then
                tempC.Value = UCase(tempC)
            End If
        Next tempC

        'Set uCell to the first instance of opName
        Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
        'If there is an instance of opName and uCell has the value check if the xid matches
        'to ensure we 're changing the right upcharge
        Do
            'Check the upcharges
            Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
            If Not uCell Is Nothing Then
                Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                    Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
                    'Correct the value in column CT
                    If Not uCell Is Nothing Then
                        If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                            uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2))
                        Else
                            Exit Do
                        End If
                    Else
                        Exit Do
                    End If
                Loop
            End If

            'Now we look in upcharge_criteria_2 column
            Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
            If Not uCell Is Nothing Then
                Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                    Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
                    'Correct the value in column CU
                    If Not uCell Is Nothing Then
                        If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                            uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2))
                        Else
                            Exit Do
                        End If
                    Else
                        Exit Do
                    End If
                Loop
            End If
        'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name
        Exit Do
        Loop

        Do
            'Check for Options
            Set aCell = rng.Find(What:=":", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Not aCell Is Nothing Then
                'Add colon to beginning and end of string to ensure we only find and
                'replace the right portion over in upcharge column
                opName = ":" & aCell.Value & ":"
                'Correct the value in column W (Option_Name)
                aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "")
                'Set corrected value (sans-colon) to opName2 and add colon to
                'beginning and end of string
                opName2 = ":" & aCell.Value & ":"
                'Note the XID of the current row so we can ensure we look for the right upcharge
                xid = ActiveSheet.Range("A" & aCell.Row).Value
                Do
                    'Check the upcharges
                    Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
                    If Not uCell Is Nothing Then
                        Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                            Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                    MatchCase:=False, SearchFormat:=False)
                                'Correct the value in column CT
                            If Not uCell Is Nothing Then
                                If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                                    uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2))
                                Else
                                    Exit Do
                                End If
                            Else
                                Exit Do
                            End If
                        Loop
                    End If

                    'Now we look in upcharge_criteria_2 column
                    Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
                    If Not uCell Is Nothing Then
                        Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                            Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _
                                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                    MatchCase:=False, SearchFormat:=False)
                            'Correct the value in column CU
                            If Not uCell Is Nothing Then
                                If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                                    uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2))
                                Else
                                    Exit Do
                                End If
                            Else
                                Exit Do
                            End If
                        Loop
                    End If
                    'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name
                    Exit Do
                Loop
            Else
                Exit Do
            End If
        Loop
    End If

    Exit Sub
ErrHandler: 'This raises the error back to the parent Sub where my Email on error handler records the error
    Err.Raise Err.Number, "colOpNaCheck", Err.Description
End Sub

The Error 13: Type Mismatch error occurs on this line

'Set uCell to the first instance of opName
            Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

When this error occurs the value of opNameis

"Order Changes. Any changes made to orders after receipt of initial PO must be made in writing via e-mail or fax. Each change will be billed. All changes made the same day as order shipment will be billed. All changes made the same day as order shipment must be received before 3:00 pm EST."

And the values it should be finding/replacing reside in the middle of these two strings

1. "PROP:ORDER CHANGES. ANY CHANGES MADE TO ORDERS AFTER RECEIPT OF INITIAL PO MUST BE MADE IN WRITING VIA E-MAIL OR FAX. EACH CHANGE WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT MUST BE RECEIVED BEFORE 3:00 PM EST.:EACH CHANGE"
2. "PROP:ORDER CHANGES. ANY CHANGES MADE TO ORDERS AFTER RECEIPT OF INITIAL PO MUST BE MADE IN WRITING VIA E-MAIL OR FAX. EACH CHANGE WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT MUST BE RECEIVED BEFORE 3:00 PM EST.:ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT"

My Questions:

1. How can I work around this .Find what:= limitation while making as few adjustments as possible to my code?
2. Could you help show me how I could implement the workaround method(s)?

Update: Almost There

Thanks to Tim's advice and method I now have the following code

'Converts Upcharge columns to all uppercase as a safety protocol,
'Checks for colons in option names and removes them from the Option Name column and in the
'upcharge columns if any upcharges correspond to that option name for the particular product.
Private Sub colOpNaCheck()

'Application.StatusBar = "(11/16) Checking option names for colons"

    Dim onRng As Range, uRng1 As Range, uRng2 As Range, tempC As Range
    Dim aCell As Collection, uCell As Collection, el, el2, el3
    Dim endRange As Long
    Dim opName As String, opName2 As String, xid As String

    endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    Set onRng = ActiveSheet.Range("W1:W" & endRange)
    Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange)
    Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange)

    Set aCell = FindAllMatches(onRng, ":")

    If Not aCell Is Nothing Then
    'Convert uRng1 & uRng2 to all uppercase
'            ActiveSheet.Range(uRng1, uRng2).Select
'            For Each tempC In Selection
'                'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase
'                'AND Row is not 1. All of these checks help us save on processing time
'                If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then
'                    tempC.Value = UCase(tempC)
'                End If
'            Next tempC
        For Each el In aCell
            'Add colon to beginning and end of string to ensure we only find and replace the right
            'portion over in upcharge column
            opName = ":" & el.Value & ":"
            'Correct the value in column W
            el.Value = Replace(ActiveSheet.Range("W" & el.Row).Value, ":", "")
            'Set corrected value (sans-colon) to opName2 and add colon to beginning and
            'end of string
            opName2 = ":" & el.Value & ":"
            'Note the XID of the current row so we can ensure we look for the right upcharge
            xid = ActiveSheet.Range("A" & el.Row).Value
            'We have the option name and the xid associated with it
            'Now we have to do a find in the upcharges column to see if we find the opName
            'Then we do an if statement and only execute if the Column A XID value matches
            'the current xid value we have now

            'set all instances of opName to uCell
            Set uCell = FindAllMatches(uRng1, opName)
            If Not uCell Is Nothing Then
                For Each el2 In uCell
                'Correct the value in column CT
                el2.Value = Replace(UCase(ActiveSheet.Range("CT" & el2.Row).Value), UCase(opName), UCase(opName2))
                Next el2
            End If

            Set uCell = FindAllMatches(uRng2, opName)
            If Not uCell Is Nothing Then
                For Each el3 In uCell
                'Correct the value in column CT
                el3.Value = Replace(UCase(ActiveSheet.Range("CT" & el3.Row).Value), UCase(opName), UCase(opName2))
                Next el3
            End If
    Next el

End If

End Sub

Function FindAllMatches(rng As Range, txt As String) As Collection
    Dim rv As New Collection, f As Range, addr As String, txtSrch As String
    Dim IsLong As Boolean

    IsLong = Len(txt) > 250
    txtSrch = IIf(IsLong, Left(txt, 250), txt)

    Set f = rng.Find(what:=txtSrch, lookat:=xlPart, MatchCase:=False)
    Do While Not f Is Nothing
        If f.Address(False, False) = addr Then Exit Do
        If Len(addr) = 0 Then addr = f.Address(False, False)
        'check for the *full* value
        If InStr(f.Value, txt) > 0 Then rv.Add f
        Set f = rng.FindNext(after:=f)
    Loop
    Set FindAllMatches = rv
End Function

However, when I use his function to find all the instances over in the upcharge column with these lines

'set all instances of opName to uCell
 Set uCell = FindAllMatches(uRng1, opName)
 If Not uCell Is Nothing Then
 ...

uCell is always displaying No Variables in the Watch window, even with the value I stated above. What am I doing wrong? Or does the FindAllMatches function need to be adjusted?

回答1:

The function FindAllMatches will return a Collection, with each member of that collection being a cell which contains a match for the item being searched for.

Sub Tester()
    Dim c As Range, col As Collection, el

    For Each c In Range("A1:A3")

        Set col = FindAllMatches(Range("D1:D5"), c.Value)
        For Each el In col
            Debug.Print c.Address & " matched " & el.Address
        Next el

    Next c

End Sub

'Return a collection of all matches for 'txt' in Range 'rng'
'  If no matches then the Count property of the returned collection
'    will  = zero
Function FindAllMatches(rng As Range, txt As String) As Collection
    Dim rv As New Collection, f As Range, addr As String, txtSrch As String
    Dim IsLong As Boolean

    IsLong = Len(txt) > 250
    txtSrch = IIf(IsLong, Left(txt, 250), txt)

   'EDIT1: added the LookIn parameter setting...
    Set f = rng.Find(what:=txtSrch, lookat:=xlPart, _
                     LookIn:=xlValues, MatchCase:=False)
    Do While Not f Is Nothing
        If f.Address(False, False) = addr Then Exit Do
        If Len(addr) = 0 Then addr = f.Address(False, False)
        If Not IsLong Then
            rv.Add f 'always add
        Else
            'check for the *full* value
            'EDIT2: make the Instr case-insensitive
             If InStr(1, f.Value, txt, vbTextCompare) > 0 Then rv.Add f
        End Id

        Set f = rng.FindNext(after:=f)
    Loop
    Set FindAllMatches = rv
End Function

回答2:

I see now that this is along the lines of nbayly's suggestion, but here is my solution.

Essentially, you search for the first 250 characters. On each cell that you match, you check (without .Find) to see if the entire string is matched.

The below sample code works on my workbook; I added the values you are searching for in column W of my active worksheet and included some where there was a mismatch after the 250-character mark. The full matches are handled properly and the mismatches are also handled properly. I assume from the level of comfort and competence you've displayed in your questions that you can integrate my example below into your code; please let me know if the code below is not clear.

Sub Test()


    Dim rng As Range, aCell As Range, uRng1 As Range, uRng2 As Range, uCell As Range, tempC As Range
    Dim endRange As Long
    Dim opName As String, opName2 As String
    Dim xid As String

    Dim StrCheck As String, StrFirst As String, BExit As Boolean

opName = "Order Changes. Any changes made to orders after receipt of initial PO must be made in writing via e-mail or fax. Each change will be billed. All changes made the same day as order shipment will be billed. All changes made the same day as order shipment must be received before 3:00 pm EST."

Set uRng1 = ActiveSheet.Range("W:W")

'Each instance where you search for opName should be replaced with this code block
'BEGIN CODE BLOCK HERE ****************************************
Set uCell = uRng1.Find(What:=Left(opName, 250), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

If Not uCell Is Nothing Then
    StrFirst = uCell.Address
    Do
        'Check if it is in fact a valid match
        On Error Resume Next
        StrCheck = vbNullString
        StrCheck = Mid(uCell.Value2, InStr(1, uCell.Value2, UCase(opName)), Len(opName))
        On Error GoTo ErrHandler
        If StrCheck = UCase(opName) Then
            'Execute your code
            uCell.Interior.Color = 255 'Change this to your code (i.e. If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ... etc.
        End If
        'Find next instance.
        On Error Resume Next
        Set uCell = uRng1.FindNext(uCell)
        Err.Clear
        On Error GoTo ErrHandler

        If uCell Is Nothing Then
            BExit = True
        ElseIf uCell.Address = StrFirst Then
            BExit = True
        End If
    Loop Until BExit
End If
'END CODE BLOCK HERE ******************************************    

ErrHandler:
    'Your error handling code here.


End Sub

回答3:

My suggestion is that you have to create a condition, before the line that errors, that checks if the string as longer than 255. If it is do a .find for the first 255 characters and INTERSECT the range with a search for your subsequent blocks of text. If the final range is not nothing (sounds like a double negative ;p) then you found your cell. Cheers,

回答4:

Well, here is my contribution, as I told you. Sorry for the delay.

NOTE: I borrow the great function of Tim Williams. If something works, let it works! Thanks Tim!.

Now you will see 2 codes, and is the same, the first one with comments, the second with less comments, just for better reading.

I keep a lot of questions, may be I don't understood clearly, but, all my hope is to help.

First one: If you want to read it, will be better to paste into VBA.

Sub colOpNaCheck_ev()

    On Error GoTo ErrHandler
    Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}"

    Dim rng As Range
    Dim aCell As Range
    Dim uRng1 As Range
    Dim uRng2 As Range
    Dim uCell As Range
    Dim tempC As Range
    Dim endRange As Long
    Dim opName As String
    Dim opName2 As String
    Dim xid As String

    'my vars
    Dim uCols1
    Dim uCols2
    Dim i
    Dim theRng As Range
    Dim theCollection As Collection

    endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX"

    Set aCell = rng.Find(what:=":", _
                         lookin:=xlValues, _
                         lookat:=xlPart, _
                         SearchOrder:=xlByRows, _
                         SearchDirection:=xlNext, _
                         MatchCase:=False, _
                         SearchFormat:=False) 'I do not get why you need this???
                                              'Obviously, I'm not seeing the data... But... not makes sense
                                              'Find JUST one ":" then go to the if...
                                              'and IF find some ":" do all the code...
                                              'wont be better just run all the code and... just that!
                                              'Think about it!

    If Not aCell Is Nothing Then 'just one cell!!! Just one!!!
                                 'There is no DO/FOR here.
        opName = ":" & aCell.Value & ":" 'store the :value: into the var
        aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":"
        opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why???

        xid = ActiveSheet.Range("A" & aCell.Row).Value 'store the value of the last cells of column
                                                       'A into the var

        Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End
        Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End

        ActiveSheet.Range(uRng1, uRng2).Select 'select both ranges
                                               'I don't know how many rows will be,
                                               'but if are less than 3000~ could be
                                               'better this way

        'My way   ====> Remember: Frank Sinatra!
        uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges
        uCols2 = uRng2.Column + 40 'to use with the formula

        Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way

        'here I use the column +40 to set the formula to UpperCase the values of columns CT and CU
        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40!
        ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])"
        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that!
        ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values
        Application.CutCopyMode = False 'Key ESC
        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas

        'this code is because, if you send to UPPER and empty value
        'the formula returns another empty value, not an empty cell
        'and then if you run over that cells, (after paste values), you
        'can not stop, you pass it over... then! The code clear any
        'blank character from the cells
        For Each i In theRng
            If IsEmpty(i) Then
                i.ClearContents
            End If
        Next i 'can not be faster! Promiss!

'        NOT USED ANYMORE
'        For Each tempC In theRng
'            'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase
'            'AND Row is not 1. All of these checks help us save on processing time
'            If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then
'                tempC.Value = UCase(tempC)
'            End If
'        Next tempC

        'Set uCell to the first instance of opName
        Set uCell = uRng1.Find(what:=UCase(opName), _
                               lookin:=xlValues, _
                               lookat:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False, _
                               SearchFormat:=False)

        'If there is an instance of opName and uCell has the value check if the xid matches
        'to ensure we 're changing the right upcharge

        'First loop!!!
        'Do 'Son... Why... WHY????? Tell WHY????????? You don't need this!!!

            'Check the upcharges
            '============================================this replace AAA
            Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match
            For Each i In theCollection 'loop over "theCollection"
                If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                    i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                    'then replace the value of i (inside the collection) with... You know better!
                Else
                    Exit Do
                End If
            Next i
            '============================================this replace AAA


            '============================================AAA
            ''Check the upcharges
            'Set uCell = uRng1.Find(what:=UCase(opName), _
            '                       lookin:=xlValues, _
            '                       lookat:=xlPart, _
            '                       SearchOrder:=xlByRows, _
            '                       SearchDirection:=xlNext, _
            '                       MatchCase:=False, _
            '                       SearchFormat:=False)
            '
            'If Not uCell Is Nothing Then
            '    Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
            '        Set uCell = uRng1.Find(what:=UCase(opName), _
            '                               lookin:=xlValues, _
            '                               lookat:=xlPart, _
            '                               SearchOrder:=xlByRows, _
            '                               SearchDirection:=xlNext, _
            '                               MatchCase:=False, _
            '                               SearchFormat:=False)
            '
            '        'Correct the value in column CT
            '        If Not uCell Is Nothing Then
            '            If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
            '                uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2))
            '            Else
            '                Exit Do
            '            End If
            '        Else
            '            Exit Do
            '        End If
            '    Loop
            'End If
            '============================================AAA


            'Now we look in upcharge_criteria_2 column
            '============================================this replace BBB
            Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <====
            For Each i In theCollection 'loop over "theCollection"
                If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB
                    i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                    'then replace the value of i (inside the collection) with... You know better!
                Else
                    Exit Do
                End If
            Next i
            '============================================this replace BBB


            '============================================BBB
            ''Now we look in upcharge_criteria_2 column
            'Set uCell = uRng2.Find(what:=UCase(opName), _
            '                       lookin:=xlValues, _
            '                       lookat:=xlPart, _
            '                       SearchOrder:=xlByRows, _
            '                       SearchDirection:=xlNext, _
            '                       MatchCase:=False, _
            '                       SearchFormat:=False)
            '
            'If Not uCell Is Nothing Then
            '    Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
            '        Set uCell = uRng2.Find(what:=UCase(opName), _
            '                               lookin:=xlValues, _
            '                               lookat:=xlPart, _
            '                               SearchOrder:=xlByRows, _
            '                               SearchDirection:=xlNext, _
            '                               MatchCase:=False, _
            '                               SearchFormat:=False)
            '
            '        'Correct the value in column CU
            '        If Not uCell Is Nothing Then
            '            If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
            '                uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2))
            '            Else
            '                Exit Do
            '            End If
            '        Else
            '            Exit Do
            '        End If
            '    Loop
            'End If
            '============================================BBB
        'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name

        'Exit Do    'Son never DO this again...
        'Loop       'Never!!!

        'end of 1st loop 'I just kill that loop!

        Set theCollection = Nothing 'Clean everything always, son.

        '2nd loop!
        Do
            'Check for Options

                '=======================================This replace CCC
                Set theCollection = FindAllMatches(rng, ":")
                For Each i In theCollection 'loop over "theCollection"
                    opName = ":" & i.Value & ":"
                    i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "")
                    opName2 = ":" & i.Value & ":"
                    xid = ActiveSheet.Range("A" & i.Row).Value
                Next i
                '=======================================This replace CCC


                '=======================================CCC
                Set aCell = rng.Find(what:=":", _
                                     lookin:=xlValues, _
                                     lookat:=xlPart, _
                                     SearchOrder:=xlByRows, _
                                     SearchDirection:=xlNext, _
                                     MatchCase:=False, _
                                     SearchFormat:=False)

            If Not aCell Is Nothing Then
                        'Usefull code, but is twice, the first one is not usefull... this seen to be {good}
                'Add colon to beginning and end of string to ensure we only find and
                'replace the right portion over in upcharge column
                opName = ":" & aCell.Value & ":"
                'Correct the value in column W (Option_Name)
                aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") 'Hey... Look!!! "XXX"... Remember!
                        'With aCell you Find into rng range... but, here is usefull, in the firts line
                        'where i put the "XXX", is not! May be I'm wrong... may not... just check that lines

                'Set corrected value (sans-colon) to opName2 and add colon to
                'beginning and end of string
                opName2 = ":" & aCell.Value & ":"
                'Note the XID of the current row so we can ensure we look for the right upcharge
                xid = ActiveSheet.Range("A" & aCell.Row).Value
                '=======================================CCC

                Set theCollection = Nothing 'Cleaning!


                'From this part, it seems to be duplicates... Just check...
                'Do  '???????????????
                    'Check the upcharges
                    '============================================this replace DDD
                    Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match
                    For Each i In theCollection 'loop over "theCollection"
                        If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                            i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                            'then replace the value of i (inside the collection) with... You know better!
                        Else
                            Exit Do
                        End If
                    Next i
                    '============================================this replace DDD

                    '============================================DDD
                    'Check the upcharges
                    'Set uCell = uRng1.Find(what:=UCase(opName), _
                    '                       lookin:=xlValues, _
                    '                       lookat:=xlPart, _
                    '                       SearchOrder:=xlByRows, _
                    '                       SearchDirection:=xlNext, _
                    '                       MatchCase:=False, _
                    '                       SearchFormat:=False)
                    '
                    'If Not uCell Is Nothing Then
                    '    Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                    '        Set uCell = uRng1.Find(what:=UCase(opName), _
                    '                               lookin:=xlValues, _
                    '                               lookat:=xlPart, _
                    '                               SearchOrder:=xlByRows, _
                    '                               SearchDirection:=xlNext, _
                    '                               MatchCase:=False, _
                    '                               SearchFormat:=False)
                    '
                    '            'Correct the value in column CT
                    '        If Not uCell Is Nothing Then
                    '            If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                    '                uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2))
                    '            Else
                    '                Exit Do
                    '            End If
                    '        Else
                    '            Exit Do
                    '        End If
                    '    Loop
                    'End If
                    '============================================DDD

                    '============================================this replace EEE
                    Set theCollection = FindAllMatches(uRng2, opName)
                    If Not theCollection = Nothing Then 'this IF is jus in case that is nothing inside!
                        For Each i In theCollection 'loop over "theCollection"
                            If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                                i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                                'then replace the value of i (inside the collection) with... You know better!
                            Else
                                Exit Do
                            End If
                        Next i
                    End If
                    '============================================this replace EEE



                    'Now we look in upcharge_criteria_2 column
                    '============================================EEE
                    'Set uCell = uRng2.Find(what:=UCase(opName), _
                    '                       lookin:=xlValues, _
                    '                       lookat:=xlPart, _
                    '                       SearchOrder:=xlByRows, _
                    '                       SearchDirection:=xlNext, _
                    '                       MatchCase:=False, _
                    '                       SearchFormat:=False)
                    '
                    'If Not uCell Is Nothing Then
                    '    Do While ActiveSheet.Range("A" & uCell.Row).Value = xid
                    '        Set uCell = uRng2.Find(what:=UCase(opName), _
                    '                               lookin:=xlValues, _
                    '                               lookat:=xlPart, _
                    '                               SearchOrder:=xlByRows, _
                    '                               SearchDirection:=xlNext, _
                    '                               MatchCase:=False, _
                    '                               SearchFormat:=False)
                    '
                    '        'Correct the value in column CU
                    '        If Not uCell Is Nothing Then
                    '            If ActiveSheet.Range("A" & uCell.Row).Value = xid Then
                    '                uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2))
                    '            Else
                    '                Exit Do
                    '            End If
                    '        Else
                    '            Exit Do
                    '        End If
                    '    Loop
                    'End If
                    'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name
                    '============================================EEE

                'Exit Do    'this loops seems to be...
                'Loop       'not usefull... :)
'            Else
'                Exit Do
            End If
        Loop
    End If

    Exit Sub
ErrHandler: 'This raises the error back to the parent Sub where my Email on error handler records the error
    Err.Raise Err.Number, "colOpNaCheck", Err.Description
End Sub

Second one:

Sub colOpNaCheck_ev2()

    On Error GoTo ErrHandler
    Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}"

    Dim rng As Range
    Dim aCell As Range
    Dim uRng1 As Range
    Dim uRng2 As Range
    Dim uCell As Range
    Dim tempC As Range
    Dim endRange As Long
    Dim opName As String
    Dim opName2 As String
    Dim xid As String
    Dim uCols1
    Dim uCols2
    Dim i
    Dim theRng As Range
    Dim theCollection As Collection

    endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX"

    Set aCell = rng.Find(what:=":", _
                         lookin:=xlValues, _
                         lookat:=xlPart, _
                         SearchOrder:=xlByRows, _
                         SearchDirection:=xlNext, _
                         MatchCase:=False, _
                         SearchFormat:=False)
    If Not aCell Is Nothing Then
        opName = ":" & aCell.Value & ":" 'store the :value: into the var
        aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":"
        opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why???
        xid = ActiveSheet.Range("A" & aCell.Row).Value
        Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End
        Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End
        ActiveSheet.Range(uRng1, uRng2).Select

        uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges
        uCols2 = uRng2.Column + 40 'to use with the formula

        Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way

        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40!
        ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])"
        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that!
        ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values
        Application.CutCopyMode = False 'Key ESC
        ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas

        For Each i In theRng
            If IsEmpty(i) Then
                i.ClearContents
            End If
        Next i 'can not be faster! Promiss!

        Set uCell = uRng1.Find(what:=UCase(opName), _
                               lookin:=xlValues, _
                               lookat:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False, _
                               SearchFormat:=False)

        Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match
        For Each i In theCollection 'loop over "theCollection"
            If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
            End If
        Next i

        Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <====
        For Each i In theCollection 'loop over "theCollection"
            If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB
                i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
            End If
        Next i

        Set theCollection = Nothing 'Clean everything always, son.

        Set theCollection = FindAllMatches(rng, ":")
        For Each i In theCollection 'loop over "theCollection"
            opName = ":" & i.Value & ":"
            i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "")
            opName2 = ":" & i.Value & ":"
            xid = ActiveSheet.Range("A" & i.Row).Value
        Next i

        Set aCell = rng.Find(what:=":", _
                             lookin:=xlValues, _
                             lookat:=xlPart, _
                             SearchOrder:=xlByRows, _
                             SearchDirection:=xlNext, _
                             MatchCase:=False, _
                             SearchFormat:=False)

            If Not aCell Is Nothing Then
                opName = ":" & aCell.Value & ":"
                aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "")
                opName2 = ":" & aCell.Value & ":"
                xid = ActiveSheet.Range("A" & aCell.Row).Value

                Set theCollection = Nothing 'Cleaning!

                Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match
                For Each i In theCollection 'loop over "theCollection"
                    If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                        i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                    End If
                Next i

                Set theCollection = FindAllMatches(uRng2, opName)
                For Each i In theCollection 'loop over "theCollection"
                   If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA
                       i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2))
                   End If
                Next i
            End If
    End If
    Exit Sub
ErrHandler:
    Err.Raise Err.Number, "colOpNaCheck", Err.Description
End Sub

And Tim's function:

Function FindAllMatches(rng As Range, txt As String) As Collection
    Dim rv As New Collection
    Dim f As Range
    Dim addr As String
    Dim txtSrch As String
    Dim IsLong As Boolean

    IsLong = Len(txt) > 250
    txtSrch = IIf(IsLong, Left(txt, 250), txt)

    Set f = rng.Find(what:=txtSrch, lookat:=xlPart, MatchCase:=False)
    Do While Not f Is Nothing
        If f.Address(False, False) = addr Then Exit Do
        If Len(addr) = 0 Then addr = f.Address(False, False)
        'check for the *full* value
        If InStr(f.Value, txt) > 0 Then rv.Add f
        Set f = rng.FindNext(after:=f)
    Loop
    Set FindAllMatches = rv
End Function

I you need emprovement, or have questions. Just tell me. Hoping you get what you need.