如何解决 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

函数FindAllMatches 将返回一个集合，该集合的每个成员都是一个单元格，其中包含正在搜索的项目的匹配项。

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

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 个字符执行 .find 并在范围内使用 INTERSECT搜索您的后续文本块。如果最终范围不是什么都没有（听起来像双重否定；p），那么您找到了您的单元格。干杯，

Answer 4

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

注意：我借用了 Tim Williams 的伟大功能。如果有什么工作，让它工作！谢谢蒂姆！

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

我保留了很多问题，可能是我没有理解清楚，但是，我所有的希望都是帮助。

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

还有蒂姆的函数：

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

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