如何在excel vba中解决Find（what：=）字符限制

Question

我刚刚在我的部门发布了一个Excel加载项，我在过去的2个多月里一直在检查大约30个验证错误。我在所有情况下都处理了错误陷阱（现在就出现了），但是今天我接到一个可怕的叫醒电话，因为我收到了两个重要错误的自动电子邮件（我在错误处理中构建的一个功能）。第一个是下面，第二个我将分开发布。

第一个错误与.Find what:=字符限制

有关

抛出此错误的Sub如下

'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

此行发生Error 13: Type Mismatch错误

'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)

发生此错误时，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."

它应该找到/替换的值位于这两个字符串的中间

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"

我的问题：

1. 如何对代码进行尽可能少的调整，以解决此.Find what:=限制？
2. 您能否告诉我如何实施变通办法？

更新：差不多

感谢Tim的建议和方法，我现在有了以下代码

'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

然而，当我使用他的函数在upcharge列中查找所有实例时，这些行

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

uCell始终在Watch窗口中显示No Variables，即使是上面提到的值。我究竟做错了什么？或者FindAllMatches函数是否需要调整？

Answer 1

函数private void secondCall(){ JsonArrayRequest pagesRequest = new JsonArrayRequest(Request.Method.GET, url, null, new Response.Listener<JSONArray>() { @Override public void onResponse(JSONArray response) { // do something with json } }, new Response.ErrorListener() { @Override public void onErrorResponse(VolleyError error) { VolleyLog.d(membership_page_tag, error.getMessage()); } }) { @Override public Priority getPriority() { return Priority.LOW; } }; AppController.getInstance().addToRequestQueue(pagesRequest, membership_page_tag); } 将返回一个Collection，该集合的每个成员都是一个包含所搜索项目匹配的单元格。

FindAllMatches

Answer 2

我现在看到这符合nbayly的建议，但这是我的解决方案。

基本上，您搜索前250个字符。在您匹配的每个单元格上，检查（不使用.Find）以查看整个字符串是否匹配。

以下示例代码适用于我的工作簿;我在活动工作表的W列中添加了您要搜索的值，并包含了250个字符后标记不匹配的位置。正确处理完整匹配并正确处理不匹配。我假设您在问题中表现出的舒适性和能力水平，您可以将我的示例集成到您的代码中;如果下面的代码不清楚，请告诉我。

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

Answer 3

我的建议是你必须在错误行之前创建一个条件，检查字符串是否长于255.如果它为前255个字符和{{1}执行.find搜索后续文本块的范围。如果最终范围不是什么（听起来像双重否定; p）那么你找到了你的细胞。欢呼声，

Answer 4

嗯，正如我告诉你的那样，这是我的贡献。抱歉耽搁了。

注意：我借用蒂姆威廉姆斯的伟大功能。如果有效，请让它有效！谢谢蒂姆！

现在您将看到2个代码，并且是相同的，第一个带有注释，第二个带有更少的注释，只是为了更好的阅读。

我提出了很多问题，可能是我不明白，但是，我所有的希望都是帮助。

第一个： 如果你想阅读它，最好粘贴到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

第二个：

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

Tim的功能：

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

我需要改善，或者有问题。就告诉我嘛。希望你得到你需要的东西。