PDA

View Full Version : [SOLVED] Remove duplications



ilyaskazi
04-19-2005, 12:35 AM
i need to remove duplication from the original value of cell:

Original value of Cell: ";NYC;BOS;NYC;NYC;BOS;DAC;LON;"

Ouput value of Cell: ";NYC;BOS;DAC;LON;"

Niko
04-19-2005, 01:46 AM
Hi ilyaskazi,

Well, i think i have an answer to ur q.

Following is the code which will identify duplicates, delelte those items and re-arrange the entire worksheet by giving you the idea how many times that item was repeated.

This is a briliant piece of work. Of course, it is not developed by me. But, i have tested it & it works gr8.

May be useful 4 u.

Cheers, :beerchug:
Niko



Insert a module by clicking Tools>Macro>Visual Basic Editor and insert this code into it.


Sub RemoveDuplicates()
' Sort by column 1...
Cells.Sort Key1:=Range("A1")
' Determine number of rows used in worksheet...
totalrows = ActiveSheet.UsedRange.Rows.Count
' Initialize counter...
Count = 1
' Step through the rows in reverse order with "Step -1".
For Row = totalrows To 2 Step -1
' Check value in column 1 to see if it is the same
' as the previous row...
If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then
' Found a dupe. Delete it and increment counter
Rows(Row).Delete
Count = Count + 1
Else ' Not a duplicate. This is a new record, so...
' put the counter value in the spreadsheet for
' the previous record:
Cells(Row, 3).Value = Count
Count = 1 ' reset counter for new record
End If
Next Row
' Don't forget last record (which is actually first)...
Cells(1, 3).Value = Count
End Sub

ilyaskazi
04-19-2005, 03:42 AM
plz understand my q and reply

I do not want to chk whole workbook or worksheet.It should check only the one cell which I hv selected.In the same cell you can see the duplicates containing 3 letter code seprated by semicolon.If found true, then it must remove the duplicate 3 letter codes

awaiting...

ilyaskazi
04-19-2005, 06:52 AM
ok someone hv solved like this for me and it works perfect...



Sub rmvDupes()
'''CAUTION - THIS CODE MAY OVERWRITE ORIGINAL DATA
Dim sOrig As String, sConv As String
Dim aOrig()
Dim i As Integer, j As Integer
On Error GoTo ErrorHandler
sOrig = Selection.value
ReDim aOrig(1 To Len(sOrig) / 4)
For i = 2 To Len(sOrig) Step 4
j = j + 1
aOrig(j) = Mid(sOrig, i, 4)
Next i
For i = UBound(aOrig) To 1 Step -1
For j = 1 To i - 1
If aOrig(i) = aOrig(j) Then aOrig(i) = ""
Next j
Next i
sConv = ";"
For i = 1 To UBound(aOrig)
sConv = sConv + aOrig(i)
Next i
Selection = sConv
Exit Sub
ErrorHandler:
MsgBox "Selection does not contain a useful value", vbInformation, "Selection not valid"
End Sub