如何解决 excel vba 中的 Find(what:=) 字符限制
Posted
技术标签:
【中文标题】如何解决 excel vba 中的 Find(what:=) 字符限制【英文标题】：How can I work around the Find(what:=) character limitation in excel vba 【发布时间】：2016-06-13 04:40:03 【问题描述】：我今天刚刚在我的部门发布了一个 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"
我的问题：
-
如何解决这个
.Find what:= 限制，同时尽可能少地对我的代码进行调整？
您能帮我看看如何实施解决方法吗？
更新：快到了
感谢 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功能需要调整？
【问题讨论】：
我来自我的牢房，无法检查代码，但我看到您使用 String car 来存储 FIND 中的内容。使用 MSGBOX 找到从 FIND 中找到的地址。这样：MSGBOX uRng1.Find(What: =Ucase(opName)).address 并检查值 .find 有 255 个字符的限制。您可以在与不区分大小写进行比较时消除UCASE 命令。
@ElbertVillarreal，这就是问题所在。 opName 字符太多，所以 uRng1.Find 什么都不返回。
@nbayly 谢谢，如上所述，我已经知道字符数限制，这正是我发布这个问题的原因。今天早些时候我也意识到我的UCase 是不必要的，但在发布之前忘记删除它。
不用担心 CaffeinatedCoder，我的评论更多是为了 Elbert 的利益。尽管不包含编码，但我正在提出有关如何解决此问题的建议作为答案。更像是一个概念。
【参考方案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
【讨论】：
这看起来将是完美的解决方案（并且需要最少的编辑来实施）。我明天测试一下。再次感谢@Tim Williams，你似乎总是来救援:) 一个小请求/问题。如何编辑它以仅返回与第二个条件匹配的值的集合（在这种情况下，字符串变量是 xid）？我需要为每个产品单独处理这些集合，唯一的方法是确保 xid 匹配。 我需要在我的情况下使用这两个版本。上面的一个可以找到选项名称的所有实例，但是在查找 upcharge 匹配时我还需要匹配 xid，因为可能有其他产品具有该选项，我只是想确保它正在替换正确的产品信息. 您的代码似乎没有在 upcharge 列中找到实例。难道我做错了什么？请参阅上面的更新。FindAllMatches 总是返回一个集合对象，即使没有匹配，所以用Is Nothing 进行测试总是会给出 False。您应该检查（在您的示例中）uCell.Count 属性不为零。【参考方案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
【讨论】：
+1 这似乎是我的问题的一个非常优雅的解决方案。唯一的缺点是这个子会变得更加臃肿，但如果这意味着能够捕获这些值（因为有许多值最终超过了find 值限制），那么它是值得的。我会在早上上班后测试这段代码，并使用我的设置。感谢您提供了一个很好的解决方案和如何实施它的示例！
我知道，很遗憾有这么多的膨胀 :( 或者，如果最后 250 个字符匹配的频率较低，您可以向后执行；也就是说，搜索最后 250 个字符，改用 instrrev instr 等。【参考方案3】：
我的建议是，您必须在出错的行之前创建一个条件，以检查字符串是否超过 255。如果是对前 255 个字符执行 .find 并在范围内使用 INTERSECT搜索您的后续文本块。如果最终范围不是什么都没有（听起来像双重否定；p），那么您找到了您的单元格。干杯，
【讨论】：
我不知道如何使用Intersect 来达到这个目的。可以举个小例子吗？
所有和都将逻辑提取到一个可重用的函数中。没有大量研究原始代码，但乍一看似乎有很多重复的逻辑，可以在单独的方法中分解
你能不能试试@TimWilliams？【参考方案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
我你需要改进，或者有问题。就告诉我嘛。希望你得到你需要的东西。
【讨论】：
以上是关于如何解决 excel vba 中的 Find(what:=) 字符限制的主要内容，如果未能解决你的问题，请参考以下文章
Excel VBA 使用 .Find 和 .FindNext 查找精确字符串