PDA

View Full Version : Solved: Remove Duplicates



kumark
06-05-2013, 11:38 PM
Hi All,

Please Help me finding the Duplicates an attachment has been made with respect to it


Regards
Kumar

patel
06-06-2013, 05:17 AM
select the range then run this macro
Sub NoDupRowsData()
Dim c As Range, cNum As Integer, r As Range, a() As Variant
' Application.ScreenUpdating = False
For Each c In Selection.Rows
cini = c.Column
cNum = c.Columns.Count
Set r = Range(Cells(c.Row, cini), Cells(c.Row, cini + cNum - 1))
r.Select
a() = UniqueRowsVal(r)
r.Clear
r.Resize(1, UBound(a)).Value = a
Next c
' Application.ScreenUpdating = True
End Sub


Public Function UniqueRowsVal(theRange As Range) As Variant
Dim colUniques As New VBA.Collection
Dim vArr As Variant
Dim vCell As Variant
Dim vLcell As Variant
Dim oRng As Excel.Range
Dim i As Long
Dim vUnique As Variant
Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
vArr = oRng
oRng.Select
On Error Resume Next
For Each vCell In vArr
If vCell <> vLcell Then
If Len(CStr(vCell)) > 0 Then
colUniques.Add vCell, CStr(vCell)
End If
End If
vLcell = vCell
Next vCell
On Error GoTo 0
ReDim vUnique(1 To colUniques.Count)
For i = LBound(vUnique) To UBound(vUnique)
vUnique(i) = colUniques(i)
Next i

UniqueRowsVal = vUnique
End Function

if problems attach please a sample file, not image

kumark
06-06-2013, 06:14 AM
Hi,

I have Attached the file ,kindly go through it

i executed the macro but showing a error subscript out of range

ReDim vUnique(1 To colUniques.Count)


kindly do look into it.

Thanks in advance for the help

Regards
Kumar

Kenneth Hobs
06-06-2013, 06:24 AM
Sub DeletedupsKen()
Dim a, V, z
With Range("A1", Range("A1").End(xlToRight))
a = .Value
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
'.CompareMode = vbBinaryCompare
For Each V In a
If Not IsEmpty(V) And Not .exists(V) Then .Add V, Nothing
Next
z = .keys
End With
.ClearContents
.Resize(, UBound(z) + 1).Value = z
End With
End Sub

patel
06-06-2013, 11:53 AM
Hi,
i executed the macro but showing a error subscript out of range
ReDim vUnique(1 To colUniques.Count)
did you select the range before macro running ? my code works with your workbook, you can try also this code with ken's sub
Sub NoDupRowsData1()
Dim c As Range, cNum As Integer, r As Range, ar() As Variant
' Application.ScreenUpdating = False
For Each c In Selection.Rows
cini = c.Column
cNum = c.Columns.Count
Set r = Range(Cells(c.Row, cini), Cells(c.Row, cini + cNum - 1))
r.Select
Call DeletedupsRow(r)
Next c
' Application.ScreenUpdating = True
End Sub
Sub DeletedupsRow(theRange As Range)
Dim a, V, z
With theRange 'Range("A1", Range("A1").End(xlToRight))
a = .Value
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
'.CompareMode = vbBinaryCompare
For Each V In a
If Not IsEmpty(V) And Not .exists(V) Then .Add V, Nothing
Next
z = .keys
End With
Stop
.ClearContents
.Resize(, UBound(z) + 1).Value = z
End With
End Sub

kumark
06-06-2013, 09:42 PM
Thanks for the macro its working fine ..Thanks alot