Steve N.
You're right, I didn't provide for a duplicated number.
But that's easy enough to fix.
when checking to see if the Dictionary Item exists:
If (Not Dict_Docs.exists(ItemNo)) then
simply add an "else" section:
Else
If (Sheets(sht).Cells(R, "B").Value & "X" = "X") Then
Sheets(sht).Cells(R, "B").Value = ItemNo2
Else
Sheets(sht).Cells(R, "B").Value = _
Sheets(sht).Cells(R, "B").Value & "," & ItemNo2
End If
If (Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value & "X" = "X") Then
Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value = ItemNo
Else
Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value = _
Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value & "," & ItemNo
End If
End IF
As for speed...
I tested with 10,000 records and it executed in less than two seconds.
Spending a lot of time to reduce it to one second seems a bit... obsessive? ;)
thanks for the review tough...
Paul
-----------------------------------------
"Do all the good you can,
By all the means you can,
In all the ways you can,
In all the places you can,
At all the times you can,
To all the people you can,
As long as ever you can." - John Wesley
-----------------------------------------
>________________________________
>From: noskosteve <noskosteve@yahoo.com>
>To: ExcelVBA@yahoogroups.com
>Sent: Monday, July 15, 2013 10:32 PM
>Subject: [ExcelVBA] Re: Transposition errors
>
>
>
>Hmmm. This is indeed a challenge.
>
>Paul S's method appears to provide for lots of compares - 6 for every two entries as well as the transposition code cost. How about looking character-by-character, then counting the number of unequal characters. Only when you get two do you check for a transposition and the rest of the string. You stop comparing that pair when you have the third unequal character....
>
>While your method has VBA doing the full string compares and this is a Macro loop, yours compares each pair 6 times, guaranteed, plus 6 transpositions.
>
>This method does the majority compares of two entries only up to three characters. This would be skewed if many of the numbers were assigned in sequence. If that was the case, you can do the comparason from the right. This would significanty shorten how far you went "into" a majority of comparisons.
>Perhaps this it too concerned with speed...?
>
>......
>Thoughts and things to explore:
>If these numbers are assigned by another department/function and simply entered by operators, it might be possible to request that a list of valid numbers be provided along with the data.
>
>......
>With the stated constraints, there are several known opportunities for false positives and false negatives in the test, i.e. ...
>
>Saad says:
>
>A list comprises hundreds of entries.
>
>"The list usually contains duplicate values" ... The assumption being that at least one is error-free.
>and
>"...there is no control list which I can compare my data with. " ... Internal comparison 'appears' necessary.
>and
>"We have 2-3 instances where this problem arises" ... It is relatively rare.
>
>Implications:
>A transposition error is relatively rare; 2-3 out of hundreds.
>
>Doing this 'internal comparison' depends on a number appearing at least twice in the list to catch the error.
>However, If an operator does the same transposition twice (seems somewhat likely), this method won't catch it. It will appear to be a valid number, though it isn't - false negative.
>
>If the number is in the list only once, it can never be flagged as a possible transposition - possible false negative.
>
>If two *valid* numbers are possible that happen to have this type of transposition, they may, or may not be flagged (depending on how many times they appear in the list). For example, if the date is in the P.O. number, a P.O. done on the 12th and another done on the 21st would be flagged as a transposition *unless* they show up more than once each. Potential false positive or false negative.
>
>Just some thoughts.
>--
>Steve N.
>
>--- "paulschreinerindy" wrote:
>>
>> Saad,
>>
>> What I would do (and have done in the past) is utilize a Dictionary object.
>> I would insert the first item into the Dictionary.
>> Then, read the second item and see if it exists in the dictionary.
>> If it does not, then:
>> transpose each of the adjacent pairs of characters and look in the dictionary for the resulting string.
>> If the string does not exist, add the original string to the dictionary and proceed.
>>
>> Keep in mind that this will ONLY check the transposition of two adjacent characters!
>>
>> I put the following macro together.
>> I created a list of 10,000 7-digit "random" numbers, and the macro ran in about 2 seconds in Excel 2010.
>>
>> It ASSUMES that your numbers are in column "A".
>> It puts the "original" value in column "B" for any suspected duplicates.
>> ------------------------------------------------
>>
>> Option Explicit
>>
>> Sub Find_Transpose()
>> Dim Dict_Docs
>> Dim nRows As Integer, R As Integer, inx As Integer, sht As String
>> Dim ItemNo As String
>> Dim ItemNo2
>> Dim AddFlag As Boolean
>>
>>
>> ThisWorkbook.Activate
>> sht = "Data"
>> Set Dict_Docs = CreateObject("Scripting.Dictionary")
>> Dict_Docs.RemoveAll
>> nRows = Application.WorksheetFunction.CountA(Sheets(sht).Range("A1:A65000"))
>> Sheets(sht).Range("B2:B" & nRows).ClearContents
>> 'Add first item to Dictionary
>> Dict_Docs.Add Sheets(sht).Cells(2, "A").Value, 2
>> ' Loop Through remaining items
>> For R = 3 To nRows
>> ItemNo = Sheets(sht).Cells(R, "A").Value
>> AddFlag = True
>> If (Not Dict_Docs.exists(ItemNo)) Then
>> If (Len(ItemNo) > 2) Then
>> For inx = 2 To Len(ItemNo)
>> If (Mid(ItemNo, inx, 1) <> Mid(ItemNo, inx - 1, 1)) Then
>> If (inx = 2) Then
>> ItemNo2 = ""
>> Else
>> ItemNo2 = Left(ItemNo, inx - 2)
>> End If
>> ItemNo2 = ItemNo2 & Mid(ItemNo, inx, 1)
>> ItemNo2 = ItemNo2 & Mid(ItemNo, inx - 1, 1)
>> ItemNo2 = ItemNo2 & Mid(ItemNo, inx + 1, Len(ItemNo) - inx)
>> If (Dict_Docs.exists(ItemNo2)) Then
>> If (Sheets(sht).Cells(R, "B").Value & "X" = "X") Then
>> Sheets(sht).Cells(R, "B").Value = ItemNo2
>> Else
>> Sheets(sht).Cells(R, "B").Value = Sheets(sht).Cells(R, "B").Value & "," & ItemNo2
>> End If
>> If (Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value & "X" = "X") Then
>> Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value = ItemNo
>> Else
>> Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value = Sheets(sht).Cells(Dict_Docs.Item(ItemNo2), "B").Value & "," & ItemNo
>> End If
>> AddFlag = False
>> Exit For
>> End If
>> End If
>> Next inx
>> If (AddFlag) Then Dict_Docs.Add ItemNo, R
>> End If
>> End If
>> Next R
>> MsgBox "Finished"
>> End Sub
>>
>> --------------------------------------------------
>> Paul
>>
>> -----------------------------------------
>> "Do all the good you can,
>> By all the means you can,
>> In all the ways you can,
>> In all the places you can,
>> At all the times you can,
>> To all the people you can,
>> As long as ever you can." - John Wesley
>> -----------------------------------------
>>
>>
>> --- In mailto:ExcelVBA%40yahoogroups.com, Saad Usman <saad.saadusman@> wrote:
>> >
>> >
>> > > Dear Excel Wizards:
>> > >
>> > > I have tried to google my issue, but have not been able to find a solution so far.
>> > >
>> > >
>> > >
>> > > The problem is that I receive data in the form of a list of hundreds of records where entries in one particular column (say part number) comprise of 7 digits. The list usually contains duplicate values, which I have been able to identify using conditional formatting. However some times, the data entry operator makes transposition errors (for e.g. feeding 1243567 instead of 1234567). I need to identify those cells where at least 5 digits are identical so that I can manually decide whether there is an error in data entry.
>> > >
>> > > Any help via formulas/macro would be greatly welcomed.
>> > >
>> > >
>> > Regards, Saad
>> >
>> > [Non-text portions of this message have been removed]
>> >
>>
>
>
>
[Non-text portions of this message have been removed]
| Reply via web post | Reply to sender | Reply to group | Start a New Topic | Messages in this topic (9) |
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar