可以将文章内容翻译成中文,广告屏蔽插件可能会导致该功能失效(如失效，请关闭广告屏蔽插件后再试):
问题:
I just released an Excel Add-In in my department today that I've been working on for the last 2+ months that checks for about 30 validation errors. I have the error trapping handled in all situations (as it appears right now), but I received a horrible wake-up call today as I received automatic emails (a feature I built into the error handling) for two vital bugs. The first of which is below, the second I will post separately.
The first bug has to do with the .Find what:= character limitation
The Sub that is throwing this error is as follows
'Converts Upcharge columns to all uppercase as a safety protocol, 'Checks for colons in option names and removes them from the Option Name column and in the 'upcharge columns if any upcharges correspond to that option name for the particular product. Private Sub colOpNaCheck() On Error GoTo ErrHandler Application.StatusBar = "(11/16) Checking option names for colons" Dim rng As Range, aCell As Range, uRng1 As Range, uRng2 As Range, uCell As Range, tempC As Range Dim endRange As Long Dim opName As String, opName2 As String Dim xid As String endRange = ActiveSheet.Range("A" & Rows.count).End(xlUp).Row Set rng = ActiveSheet.Range("W1:W" & endRange) Set aCell = rng.Find(What:=":", LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not aCell Is Nothing Then 'Add colon to beginning and end of string to ensure we only find and replace the right 'portion over in upcharge column opName = ":" & aCell.Value & ":" 'Correct the value in column W aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") 'Set corrected value (sans-colon) to opName2 and add colon to beginning and 'end of string opName2 = ":" & aCell.Value & ":" 'Note the XID of the current row so we can ensure we look for the right upcharge xid = ActiveSheet.Range("A" & aCell.Row).Value 'We have the option name and the xid associated with it 'Now we have to do a find in the upcharges column to see if we find the opName 'Then we do an if statement and only execute if the the Column A XID value matches 'the current xid value we have now Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'Convert uRng1 & uRng2 to all uppercase just to make sure they will be detected when using Find ActiveSheet.Range(uRng1, uRng2).Select For Each tempC In Selection 'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase 'AND Row is not 1. All of these checks help us save on processing time If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then tempC.Value = UCase(tempC) End If Next tempC 'Set uCell to the first instance of opName Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'If there is an instance of opName and uCell has the value check if the xid matches 'to ensure we 're changing the right upcharge Do 'Check the upcharges Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not uCell Is Nothing Then Do While ActiveSheet.Range("A" & uCell.Row).Value = xid Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'Correct the value in column CT If Not uCell Is Nothing Then If ActiveSheet.Range("A" & uCell.Row).Value = xid Then uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) Else Exit Do End If Else Exit Do End If Loop End If 'Now we look in upcharge_criteria_2 column Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not uCell Is Nothing Then Do While ActiveSheet.Range("A" & uCell.Row).Value = xid Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'Correct the value in column CU If Not uCell Is Nothing Then If ActiveSheet.Range("A" & uCell.Row).Value = xid Then uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) Else Exit Do End If Else Exit Do End If Loop End If 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name Exit Do Loop Do 'Check for Options Set aCell = rng.Find(What:=":", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not aCell Is Nothing Then 'Add colon to beginning and end of string to ensure we only find and 'replace the right portion over in upcharge column opName = ":" & aCell.Value & ":" 'Correct the value in column W (Option_Name) aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") 'Set corrected value (sans-colon) to opName2 and add colon to 'beginning and end of string opName2 = ":" & aCell.Value & ":" 'Note the XID of the current row so we can ensure we look for the right upcharge xid = ActiveSheet.Range("A" & aCell.Row).Value Do 'Check the upcharges Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not uCell Is Nothing Then Do While ActiveSheet.Range("A" & uCell.Row).Value = xid Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'Correct the value in column CT If Not uCell Is Nothing Then If ActiveSheet.Range("A" & uCell.Row).Value = xid Then uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) Else Exit Do End If Else Exit Do End If Loop End If 'Now we look in upcharge_criteria_2 column Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not uCell Is Nothing Then Do While ActiveSheet.Range("A" & uCell.Row).Value = xid Set uCell = uRng2.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'Correct the value in column CU If Not uCell Is Nothing Then If ActiveSheet.Range("A" & uCell.Row).Value = xid Then uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) Else Exit Do End If Else Exit Do End If Loop End If 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name Exit Do Loop Else Exit Do End If Loop End If Exit Sub ErrHandler: 'This raises the error back to the parent Sub where my Email on error handler records the error Err.Raise Err.Number, "colOpNaCheck", Err.Description End Sub
The Error 13: Type Mismatch error occurs on this line
'Set uCell to the first instance of opName Set uCell = uRng1.Find(What:=UCase(opName), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
When this error occurs the value of opNameis
"Order Changes. Any changes made to orders after receipt of initial PO must be made in writing via e-mail or fax. Each change will be billed. All changes made the same day as order shipment will be billed. All changes made the same day as order shipment must be received before 3:00 pm EST."
And the values it should be finding/replacing reside in the middle of these two strings
1. "PROP:ORDER CHANGES. ANY CHANGES MADE TO ORDERS AFTER RECEIPT OF INITIAL PO MUST BE MADE IN WRITING VIA E-MAIL OR FAX. EACH CHANGE WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT MUST BE RECEIVED BEFORE 3:00 PM EST.:EACH CHANGE" 2. "PROP:ORDER CHANGES. ANY CHANGES MADE TO ORDERS AFTER RECEIPT OF INITIAL PO MUST BE MADE IN WRITING VIA E-MAIL OR FAX. EACH CHANGE WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT WILL BE BILLED. ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT MUST BE RECEIVED BEFORE 3:00 PM EST.:ALL CHANGES MADE THE SAME DAY AS ORDER SHIPMENT"
My Questions:
- How can I work around this
.Find what:= limitation while making as few adjustments as possible to my code? - Could you help show me how I could implement the workaround method(s)?
Update: Almost There
Thanks to Tim's advice and method I now have the following code
'Converts Upcharge columns to all uppercase as a safety protocol, 'Checks for colons in option names and removes them from the Option Name column and in the 'upcharge columns if any upcharges correspond to that option name for the particular product. Private Sub colOpNaCheck() 'Application.StatusBar = "(11/16) Checking option names for colons" Dim onRng As Range, uRng1 As Range, uRng2 As Range, tempC As Range Dim aCell As Collection, uCell As Collection, el, el2, el3 Dim endRange As Long Dim opName As String, opName2 As String, xid As String endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row Set onRng = ActiveSheet.Range("W1:W" & endRange) Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) Set aCell = FindAllMatches(onRng, ":") If Not aCell Is Nothing Then 'Convert uRng1 & uRng2 to all uppercase ' ActiveSheet.Range(uRng1, uRng2).Select ' For Each tempC In Selection ' 'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase ' 'AND Row is not 1. All of these checks help us save on processing time ' If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then ' tempC.Value = UCase(tempC) ' End If ' Next tempC For Each el In aCell 'Add colon to beginning and end of string to ensure we only find and replace the right 'portion over in upcharge column opName = ":" & el.Value & ":" 'Correct the value in column W el.Value = Replace(ActiveSheet.Range("W" & el.Row).Value, ":", "") 'Set corrected value (sans-colon) to opName2 and add colon to beginning and 'end of string opName2 = ":" & el.Value & ":" 'Note the XID of the current row so we can ensure we look for the right upcharge xid = ActiveSheet.Range("A" & el.Row).Value 'We have the option name and the xid associated with it 'Now we have to do a find in the upcharges column to see if we find the opName 'Then we do an if statement and only execute if the Column A XID value matches 'the current xid value we have now 'set all instances of opName to uCell Set uCell = FindAllMatches(uRng1, opName) If Not uCell Is Nothing Then For Each el2 In uCell 'Correct the value in column CT el2.Value = Replace(UCase(ActiveSheet.Range("CT" & el2.Row).Value), UCase(opName), UCase(opName2)) Next el2 End If Set uCell = FindAllMatches(uRng2, opName) If Not uCell Is Nothing Then For Each el3 In uCell 'Correct the value in column CT el3.Value = Replace(UCase(ActiveSheet.Range("CT" & el3.Row).Value), UCase(opName), UCase(opName2)) Next el3 End If Next el End If End Sub Function FindAllMatches(rng As Range, txt As String) As Collection Dim rv As New Collection, f As Range, addr As String, txtSrch As String Dim IsLong As Boolean IsLong = Len(txt) > 250 txtSrch = IIf(IsLong, Left(txt, 250), txt) Set f = rng.Find(what:=txtSrch, lookat:=xlPart, MatchCase:=False) Do While Not f Is Nothing If f.Address(False, False) = addr Then Exit Do If Len(addr) = 0 Then addr = f.Address(False, False) 'check for the *full* value If InStr(f.Value, txt) > 0 Then rv.Add f Set f = rng.FindNext(after:=f) Loop Set FindAllMatches = rv End Function
However, when I use his function to find all the instances over in the upcharge column with these lines
'set all instances of opName to uCell Set uCell = FindAllMatches(uRng1, opName) If Not uCell Is Nothing Then ...
uCell is always displaying No Variables in the Watch window, even with the value I stated above. What am I doing wrong? Or does the FindAllMatches function need to be adjusted?
回答1:
The function FindAllMatches will return a Collection, with each member of that collection being a cell which contains a match for the item being searched for.
Sub Tester() Dim c As Range, col As Collection, el For Each c In Range("A1:A3") Set col = FindAllMatches(Range("D1:D5"), c.Value) For Each el In col Debug.Print c.Address & " matched " & el.Address Next el Next c End Sub 'Return a collection of all matches for 'txt' in Range 'rng' ' If no matches then the Count property of the returned collection ' will = zero Function FindAllMatches(rng As Range, txt As String) As Collection Dim rv As New Collection, f As Range, addr As String, txtSrch As String Dim IsLong As Boolean IsLong = Len(txt) > 250 txtSrch = IIf(IsLong, Left(txt, 250), txt) 'EDIT1: added the LookIn parameter setting... Set f = rng.Find(what:=txtSrch, lookat:=xlPart, _ LookIn:=xlValues, MatchCase:=False) Do While Not f Is Nothing If f.Address(False, False) = addr Then Exit Do If Len(addr) = 0 Then addr = f.Address(False, False) If Not IsLong Then rv.Add f 'always add Else 'check for the *full* value 'EDIT2: make the Instr case-insensitive If InStr(1, f.Value, txt, vbTextCompare) > 0 Then rv.Add f End Id Set f = rng.FindNext(after:=f) Loop Set FindAllMatches = rv End Function
回答2:
I see now that this is along the lines of nbayly's suggestion, but here is my solution.
Essentially, you search for the first 250 characters. On each cell that you match, you check (without .Find) to see if the entire string is matched.
The below sample code works on my workbook; I added the values you are searching for in column W of my active worksheet and included some where there was a mismatch after the 250-character mark. The full matches are handled properly and the mismatches are also handled properly. I assume from the level of comfort and competence you've displayed in your questions that you can integrate my example below into your code; please let me know if the code below is not clear.
Sub Test() Dim rng As Range, aCell As Range, uRng1 As Range, uRng2 As Range, uCell As Range, tempC As Range Dim endRange As Long Dim opName As String, opName2 As String Dim xid As String Dim StrCheck As String, StrFirst As String, BExit As Boolean opName = "Order Changes. Any changes made to orders after receipt of initial PO must be made in writing via e-mail or fax. Each change will be billed. All changes made the same day as order shipment will be billed. All changes made the same day as order shipment must be received before 3:00 pm EST." Set uRng1 = ActiveSheet.Range("W:W") 'Each instance where you search for opName should be replaced with this code block 'BEGIN CODE BLOCK HERE **************************************** Set uCell = uRng1.Find(What:=Left(opName, 250), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not uCell Is Nothing Then StrFirst = uCell.Address Do 'Check if it is in fact a valid match On Error Resume Next StrCheck = vbNullString StrCheck = Mid(uCell.Value2, InStr(1, uCell.Value2, UCase(opName)), Len(opName)) On Error GoTo ErrHandler If StrCheck = UCase(opName) Then 'Execute your code uCell.Interior.Color = 255 'Change this to your code (i.e. If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ... etc. End If 'Find next instance. On Error Resume Next Set uCell = uRng1.FindNext(uCell) Err.Clear On Error GoTo ErrHandler If uCell Is Nothing Then BExit = True ElseIf uCell.Address = StrFirst Then BExit = True End If Loop Until BExit End If 'END CODE BLOCK HERE ****************************************** ErrHandler: 'Your error handling code here. End Sub
回答3:
My suggestion is that you have to create a condition, before the line that errors, that checks if the string as longer than 255. If it is do a .find for the first 255 characters and INTERSECT the range with a search for your subsequent blocks of text. If the final range is not nothing (sounds like a double negative ;p) then you found your cell. Cheers,
回答4:
Well, here is my contribution, as I told you. Sorry for the delay.
NOTE: I borrow the great function of Tim Williams. If something works, let it works! Thanks Tim!.
Now you will see 2 codes, and is the same, the first one with comments, the second with less comments, just for better reading.
I keep a lot of questions, may be I don't understood clearly, but, all my hope is to help.
First one: If you want to read it, will be better to paste into VBA.
Sub colOpNaCheck_ev() On Error GoTo ErrHandler Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}" Dim rng As Range Dim aCell As Range Dim uRng1 As Range Dim uRng2 As Range Dim uCell As Range Dim tempC As Range Dim endRange As Long Dim opName As String Dim opName2 As String Dim xid As String 'my vars Dim uCols1 Dim uCols2 Dim i Dim theRng As Range Dim theCollection As Collection endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX" Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) 'I do not get why you need this??? 'Obviously, I'm not seeing the data... But... not makes sense 'Find JUST one ":" then go to the if... 'and IF find some ":" do all the code... 'wont be better just run all the code and... just that! 'Think about it! If Not aCell Is Nothing Then 'just one cell!!! Just one!!! 'There is no DO/FOR here. opName = ":" & aCell.Value & ":" 'store the :value: into the var aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":" opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why??? xid = ActiveSheet.Range("A" & aCell.Row).Value 'store the value of the last cells of column 'A into the var Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End ActiveSheet.Range(uRng1, uRng2).Select 'select both ranges 'I don't know how many rows will be, 'but if are less than 3000~ could be 'better this way 'My way ====> Remember: Frank Sinatra! uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges uCols2 = uRng2.Column + 40 'to use with the formula Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way 'here I use the column +40 to set the formula to UpperCase the values of columns CT and CU ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40! ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])" ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that! ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values Application.CutCopyMode = False 'Key ESC ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas 'this code is because, if you send to UPPER and empty value 'the formula returns another empty value, not an empty cell 'and then if you run over that cells, (after paste values), you 'can not stop, you pass it over... then! The code clear any 'blank character from the cells For Each i In theRng If IsEmpty(i) Then i.ClearContents End If Next i 'can not be faster! Promiss! ' NOT USED ANYMORE ' For Each tempC In theRng ' 'If cell does not contain an Error AND is not missing a value/is empty AND cell is not already all uppercase ' 'AND Row is not 1. All of these checks help us save on processing time ' If Not IsError(tempC) And Not IsMissing(tempC) And tempC.Value <> UCase(tempC.Value) And tempC.Row <> 1 Then ' tempC.Value = UCase(tempC) ' End If ' Next tempC 'Set uCell to the first instance of opName Set uCell = uRng1.Find(what:=UCase(opName), _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) 'If there is an instance of opName and uCell has the value check if the xid matches 'to ensure we 're changing the right upcharge 'First loop!!! 'Do 'Son... Why... WHY????? Tell WHY????????? You don't need this!!! 'Check the upcharges '============================================this replace AAA Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace AAA '============================================AAA ''Check the upcharges 'Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CT ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================AAA 'Now we look in upcharge_criteria_2 column '============================================this replace BBB Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <==== For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace BBB '============================================BBB ''Now we look in upcharge_criteria_2 column 'Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CU ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================BBB 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name 'Exit Do 'Son never DO this again... 'Loop 'Never!!! 'end of 1st loop 'I just kill that loop! Set theCollection = Nothing 'Clean everything always, son. '2nd loop! Do 'Check for Options '=======================================This replace CCC Set theCollection = FindAllMatches(rng, ":") For Each i In theCollection 'loop over "theCollection" opName = ":" & i.Value & ":" i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "") opName2 = ":" & i.Value & ":" xid = ActiveSheet.Range("A" & i.Row).Value Next i '=======================================This replace CCC '=======================================CCC Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then 'Usefull code, but is twice, the first one is not usefull... this seen to be {good} 'Add colon to beginning and end of string to ensure we only find and 'replace the right portion over in upcharge column opName = ":" & aCell.Value & ":" 'Correct the value in column W (Option_Name) aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") 'Hey... Look!!! "XXX"... Remember! 'With aCell you Find into rng range... but, here is usefull, in the firts line 'where i put the "XXX", is not! May be I'm wrong... may not... just check that lines 'Set corrected value (sans-colon) to opName2 and add colon to 'beginning and end of string opName2 = ":" & aCell.Value & ":" 'Note the XID of the current row so we can ensure we look for the right upcharge xid = ActiveSheet.Range("A" & aCell.Row).Value '=======================================CCC Set theCollection = Nothing 'Cleaning! 'From this part, it seems to be duplicates... Just check... 'Do '??????????????? 'Check the upcharges '============================================this replace DDD Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i '============================================this replace DDD '============================================DDD 'Check the upcharges 'Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng1.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CT ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CT" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If '============================================DDD '============================================this replace EEE Set theCollection = FindAllMatches(uRng2, opName) If Not theCollection = Nothing Then 'this IF is jus in case that is nothing inside! For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) 'then replace the value of i (inside the collection) with... You know better! Else Exit Do End If Next i End If '============================================this replace EEE 'Now we look in upcharge_criteria_2 column '============================================EEE 'Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' 'If Not uCell Is Nothing Then ' Do While ActiveSheet.Range("A" & uCell.Row).Value = xid ' Set uCell = uRng2.Find(what:=UCase(opName), _ ' lookin:=xlValues, _ ' lookat:=xlPart, _ ' SearchOrder:=xlByRows, _ ' SearchDirection:=xlNext, _ ' MatchCase:=False, _ ' SearchFormat:=False) ' ' 'Correct the value in column CU ' If Not uCell Is Nothing Then ' If ActiveSheet.Range("A" & uCell.Row).Value = xid Then ' uCell = Replace(UCase(ActiveSheet.Range("CU" & uCell.Row).Value), UCase(opName), UCase(opName2)) ' Else ' Exit Do ' End If ' Else ' Exit Do ' End If ' Loop 'End If 'Exit the Do Statement since we've fixed all the upcharges for this particular Option Name '============================================EEE 'Exit Do 'this loops seems to be... 'Loop 'not usefull... :) ' Else ' Exit Do End If Loop End If Exit Sub ErrHandler: 'This raises the error back to the parent Sub where my Email on error handler records the error Err.Raise Err.Number, "colOpNaCheck", Err.Description End Sub
Second one:
Sub colOpNaCheck_ev2() On Error GoTo ErrHandler Application.StatusBar = "(11/16) Checking option names for colons {ev 0.1}" Dim rng As Range Dim aCell As Range Dim uRng1 As Range Dim uRng2 As Range Dim uCell As Range Dim tempC As Range Dim endRange As Long Dim opName As String Dim opName2 As String Dim xid As String Dim uCols1 Dim uCols2 Dim i Dim theRng As Range Dim theCollection As Collection endRange = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row Set rng = ActiveSheet.Range("W1:W" & endRange) 'Remember this, when you'll see "XXX" Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then opName = ":" & aCell.Value & ":" 'store the :value: into the var aCell.Value = Replace(aCell.Value, ":", "") 'remove any ":" opName2 = ":" & aCell.Value & ":" 'againg store the :value: into the var (????) Why??? xid = ActiveSheet.Range("A" & aCell.Row).Value Set uRng1 = ActiveSheet.Range("CT1:CT" & endRange) 'CT1 ==> End Set uRng2 = ActiveSheet.Range("CU1:CU" & endRange) 'CU1 ==> End ActiveSheet.Range(uRng1, uRng2).Select uCols1 = uRng1.Column + 40 'store a number of column +40 for both ranges uCols2 = uRng2.Column + 40 'to use with the formula Set theRng = Union(uRng1, uRng2) 'it is bette to handle this way ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols1)).FormulaR1C1 = "=UPPER(RC[-" & uCols1 & "])" 'Formula is +40! ActiveSheet.Range(Cells(2, uCols2), Cells(endRange, uCols2)).FormulaR1C1 = "=UPPER(RC[-" & uCols2 & "])" '"=UPPER(RC[-40])" ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).Copy 'just that! ActiveSheet.Range(Cells(2, uRng1.Column), Cells(endRange, uRng2.Column)).PasteSpecial Paste:=xlPasteValues 'paste just the values Application.CutCopyMode = False 'Key ESC ActiveSheet.Range(Cells(2, uCols1), Cells(endRange, uCols2)).ClearContents 'Remove the formulas For Each i In theRng If IsEmpty(i) Then i.ClearContents End If Next i 'can not be faster! Promiss! Set uCell = uRng1.Find(what:=UCase(opName), _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = FindAllMatches(uRng2, opName) 'See just change uRgn1 for [[[[uRng2]]] <==== For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? i take it from BBB i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = Nothing 'Clean everything always, son. Set theCollection = FindAllMatches(rng, ":") For Each i In theCollection 'loop over "theCollection" opName = ":" & i.Value & ":" i.Value = Replace(ActiveSheet.Range("W" & i.Row).Value, ":", "") opName2 = ":" & i.Value & ":" xid = ActiveSheet.Range("A" & i.Row).Value Next i Set aCell = rng.Find(what:=":", _ lookin:=xlValues, _ lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) If Not aCell Is Nothing Then opName = ":" & aCell.Value & ":" aCell = Replace(ActiveSheet.Range("W" & aCell.Row).Value, ":", "") opName2 = ":" & aCell.Value & ":" xid = ActiveSheet.Range("A" & aCell.Row).Value Set theCollection = Nothing 'Cleaning! Set theCollection = FindAllMatches(uRng1, opName) 'theCollection takes all the cells that match For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i Set theCollection = FindAllMatches(uRng2, opName) For Each i In theCollection 'loop over "theCollection" If ActiveSheet.Range("A" & i.Row).Value = xid Then 'Remember this line? I Take it from AAA i.Value = Replace(UCase(ActiveSheet.Range("CT" & i.Row).Value), UCase(opName), UCase(opName2)) End If Next i End If End If Exit Sub ErrHandler: Err.Raise Err.Number, "colOpNaCheck", Err.Description End Sub
And Tim's function:
Function FindAllMatches(rng As Range, txt As String) As Collection Dim rv As New Collection Dim f As Range Dim addr As String Dim txtSrch As String Dim IsLong As Boolean IsLong = Len(txt) > 250 txtSrch = IIf(IsLong, Left(txt, 250), txt) Set f = rng.Find(what:=txtSrch, lookat:=xlPart, MatchCase:=False) Do While Not f Is Nothing If f.Address(False, False) = addr Then Exit Do If Len(addr) = 0 Then addr = f.Address(False, False) 'check for the *full* value If InStr(f.Value, txt) > 0 Then rv.Add f Set f = rng.FindNext(after:=f) Loop Set FindAllMatches = rv End Function
I you need emprovement, or have questions. Just tell me. Hoping you get what you need.
