[ExcelVBA] Re: Transposition errors

 

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 ExcelVBA@yahoogroups.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]
>

__._,_.___

Reply via web post

Reply to sender

Reply to group

Start a New Topic

Messages in this topic (7)

Recent Activity:

• New Members 1

Visit Your Group

----------------------------------
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

----------------------------------

Switch to: Text-Only, Daily Digest • Unsubscribe • Terms of Use • Send us Feedback

.

__,_._,___