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;"
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.