如何解决excel vba中的Find（what：=）字符限制问题
我刚刚在我的部门发布了一个Excel插件，我已经在过去的2个月时间里检查了大约30个validation错误。 我在所有情况下都处理了错误陷阱（就像现在它出现的那样），但是今天我收到了一个可怕的唤醒电话，因为我收到了两个重要错误的自动电子邮件（这是我在error handling中构build的一个function）。 第一个是下面，第二个我会分开发表。
第一个bug与。find.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."
它应该find/replace的价值在于这两个string的中间
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:=限制，尽可能less地调整我的代码？ - 你能帮我看看我可以如何实施解决方法吗？
更新：几乎在那里
感谢蒂姆的build议和方法，我现在有以下代码
'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函数？
函数FindAllMatches将返回一个集合，该集合的每个成员都是一个包含正在search的项目匹配的单元格。
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
我现在看到，这是nbayly的build议，但这是我的解决scheme。
本质上，您search的前250个字符。 在每个匹配的单元格上，检查（不包含.Find）以查看整个string是否匹配。
下面的示例代码适用于我的工作簿; 我在活动工作表的W列中添加了要search的值，并在250个字符后面包含了一些不匹配的地方。 完整的匹配处理正确，错配也得到妥善处理。 我从你在问题中performance出来的舒适和能力的angular度来看，你可以把我的例子整合到你的代码中; 请让我知道如果下面的代码不清楚。
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 (ie 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
我的build议是，你必须在错误行之前创build一个条件，检查string是否超过了255.如果是为前255个字符做一个.find ，并通过search你的后续块来INTERSECT范围的文本。 如果最后的范围不是什么（听起来像一个双重否定; p），那么你find你的细胞。 干杯，
那么，正如我告诉过你的，这是我的贡献。 抱歉耽搁了。
注意：我借用了Tim Williams的伟大function。 如果有效果，让它工作！ 谢谢Tim！
现在你会看到2个代码，是相同的，第一个有评论，第二个有较less的评论，只是为了更好的阅读。
我保留了很多的问题，可能是我不是很清楚，但是，我所有的希望都是帮助的。
第一个：如果你想读它，将会更好地粘贴到VBA中。
Sub colOpNaCheck_ev() On Error GoTo ErrHandler Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}" Dim rng As Range Dim aCell As Range Dim uRng1 As Range Dim uRng2 As Range Dim uCell As Range Dim tempC As Range Dim endRange As Long Dim opName As String Dim opName2 As String Dim xid As String 'my vars Dim uCols1 Dim uCols2 Dim i Dim theRng As Range Dim theCollection As Collection endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX" Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) 'I do not get why you need this??? 'Obviously, I'm not seeing the data... But... not makes sense 'Find JUST one ":" then go to the if... 'and IF find some ":" do all the code... 'wont be better just run all the code and... just that! 'Think about it! If Not aCell Is Nothing Then 'just one cell!!! Just one!!! 'There is no DO/FOR here. opName = ":" & aCell.Value & ":" 'store the :value: into the var aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":" opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why??? xid = ActiveSheet.Range("A" & aCell.Row).Value 'store the value of the last cells of column 'A into the var Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End ActiveSheet.Range(uRng1, uRng2).Select 'select both ranges 'I don't know how many rows will be, 'but if are less than 3000~ could be 'better this way 'My way ====> Remember: Frank Sinatra! uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges uCols2 = uRng2.Column + 40 'to use with the formula Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way 'here I use the column +40 to set the formula to UpperCase the values of columns CT and CU ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40! ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])" ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that! ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values Application.CutCopyMode = False 'Key ESC ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas 'this code is because, if you send to UPPER and empty value 'the formula returns another empty value, not an empty cell 'and then if you run over that cells, (after paste values), you 'can not stop, you pass it over... then! The code clear any 'blank character from the cells For Each i In theRng If IsEmpty(i) Then i.ClearContents End If Next i 'can not be faster! Promiss! ' NOT USED ANYMORE ' For Each tempC In theRng ' 'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase ' 'AND Row is not 1. All of these checks help us save on processing time ' If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then ' tempC.Value = UCase(tempC) ' End If ' Next tempC 'Set uCell to the first instance of opName Set uCell = uRng1.Find(what:=UCase(opName), _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) 'If there is an instance of opName and uCell has the value check if the xid matches 'to ensure we 're changing the right upcharge 'First loop!!! 'Do 'Son... Why... WHY????? Tell WHY????????? You don't need this!!! 'Check the upcharges '============================================this replace AAA Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace AAA '============================================AAA ''Check the upcharges 'Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CT ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================AAA 'Now we look in upcharge_criteria_2 column '============================================this replace BBB Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <==== For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace BBB '============================================BBB ''Now we look in upcharge_criteria_2 column 'Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CU ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================BBB 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name 'Exit Do 'Son never DO this again... 'Loop 'Never!!! 'end of 1st loop 'I just kill that loop! Set theCollection = Nothing 'Clean everything always, son. '2nd loop! Do 'Check for Options '=======================================This replace CCC Set theCollection = FindAllMatches(rng, ":") For Each i In theCollection 'loop over "theCollection" opName = ":" & i.Value & ":" i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "") opName2 = ":" & i.Value & ":" xid = ActiveSheet.Range("A" & i.Row).Value Next i '=======================================This replace CCC '=======================================CCC Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then 'Usefull code, but is twice, the first one is not usefull... this seen to be {good} 'Add colon to beginning and end of string to ensure we only find and 'replace the right portion over in upcharge column opName = ":" & aCell.Value & ":" 'Correct the value in column W (Option_Name) aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") 'Hey... Look!!! "XXX"... Remember! 'With aCell you Find into rng range... but, here is usefull, in the firts line 'where i put the "XXX", is not! May be I'm wrong... may not... just check that lines 'Set corrected value (sans-colon) to opName2 and add colon to 'beginning and end of string opName2 = ":" & aCell.Value & ":" 'Note the XID of the current row so we can ensure we look for the right upcharge xid = ActiveSheet.Range("A" & aCell.Row).Value '=======================================CCC Set theCollection = Nothing 'Cleaning! 'From this part, it seems to be duplicates... Just check... 'Do '??????????????? 'Check the upcharges '============================================this replace DDD Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace DDD '============================================DDD 'Check the upcharges 'Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CT ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================DDD '============================================this replace EEE Set theCollection = FindAllMatches(uRng2, opName) If Not theCollection = Nothing Then 'this IF is jus in case that is nothing inside! For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i End If '============================================this replace EEE 'Now we look in upcharge_criteria_2 column '============================================EEE 'Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CU ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name '============================================EEE 'Exit Do 'this loops seems to be... 'Loop 'not usefull... :) ' Else ' Exit Do End If Loop End If Exit Sub ErrHandler: 'This raises the error back to the parent Sub where my Email on error handler records the error Err.Raise Err.Number, "colOpNaCheck", Err.Description End Sub
Second one:
Sub colOpNaCheck_ev2() On Error GoTo ErrHandler Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}" Dim rng As Range Dim aCell As Range Dim uRng1 As Range Dim uRng2 As Range Dim uCell As Range Dim tempC As Range Dim endRange As Long Dim opName As String Dim opName2 As String Dim xid As String Dim uCols1 Dim uCols2 Dim i Dim theRng As Range Dim theCollection As Collection endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX" Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then opName = ":" & aCell.Value & ":" 'store the :value: into the var aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":" opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why??? xid = ActiveSheet.Range("A" & aCell.Row).Value Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End ActiveSheet.Range(uRng1, uRng2).Select uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges uCols2 = uRng2.Column + 40 'to use with the formula Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40! ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])" ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that! ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values Application.CutCopyMode = False 'Key ESC ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas For Each i In theRng If IsEmpty(i) Then i.ClearContents End If Next i 'can not be faster! Promiss! Set uCell = uRng1.Find(what:=UCase(opName), _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <==== For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = Nothing 'Clean everything always, son. Set theCollection = FindAllMatches(rng, ":") For Each i In theCollection 'loop over "theCollection" opName = ":" & i.Value & ":" i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "") opName2 = ":" & i.Value & ":" xid = ActiveSheet.Range("A" & i.Row).Value Next i Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then opName = ":" & aCell.Value & ":" aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") opName2 = ":" & aCell.Value & ":" xid = ActiveSheet.Range("A" & aCell.Row).Value Set theCollection = Nothing 'Cleaning! Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = FindAllMatches(uRng2, opName) For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i End If End If Exit Sub ErrHandler: Err.Raise Err.Number, "colOpNaCheck", Err.Description End Sub
And Tim's function:
Function FindAllMatches(rng As Range, txt As String) As Collection Dim rv As New Collection Dim f As Range Dim addr As String Dim txtSrch As String Dim IsLong As Boolean IsLong = Len(txt) > 250 txtSrch = IIf(IsLong, Left(txt, 250), txt) Set f = rng.Find(what:=txtSrch, lookat:=xlPart, MatchCase:=False) Do While Not f Is Nothing If f.Address(False, False) = addr Then Exit Do If Len(addr) = 0 Then addr = f.Address(False, False) 'check for the *full* value If InStr(f.Value, txt) > 0 Then rv.Add f Set f = rng.FindNext(after:=f) Loop Set FindAllMatches = rv End Function
I you need emprovement, or have questions. Just tell me. Hoping you get what you need.