deleting rows that have double key .. but delete the last found

Amien90
Amien90 used Ask the Experts™
on
key, date, text

10, 20100101, text
20, 20100201, text
30, 20100101, text
10, 20100201, text
10, 20100301, text
50, 20100501, text
30, 20100202, text

where key = 10 and 30 are double .. i need to make the keys unique .. and keep the last found key

20, 20100201, text
10, 20100301, text
50, 20100501, text
30, 20100202, text
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi,

try

Kris
Sub kTest()
Dim ka, k(), i As Long, n As Long, dic As Object, c As Long, q()
Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
With Range("a1")
    ka = .CurrentRegion.Offset(1).Resize(, 3).Value
    ReDim k(1 To UBound(ka, 1), 1 To 3)
    For i = 1 To UBound(ka, 1)
        If Not dic.exists(ka(i, 1)) Then
            n = n + 1
            For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
            dic.Add ka(i, 1), Array(n, 3)
        Else
            q = dic.Item(ka(i, 1))
            For c = 1 To UBound(ka, 2): k(q(0), c) = ka(i, c): Next
            dic.Item(ka(i, 1)) = q
        End If
    Next
    If n > 0 Then
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Resize(n, UBound(ka, 2)).Value = k
    End If
End With
Set dic = Nothing
End Sub

Open in new window

Author

Commented:
is it really this complicated?
Hi,

Have a look at this lesson:

http://www.vbaexpress.com/training/lesson01.htm

Or you could do this manually as well.

Assume your data layed in A1:C8

in D1, type "temp" without quotes

in D2 and copied down

=(COUNTIF($A$2:A2,A2)=COUNTIF($A$2:$A$8,A2))

now select A1:D8, goto Data Filter > Autofilter > Select FALSE

delete all rows.

Kris
Build an E-Commerce Site with Angular 5

Learn how to build an E-Commerce site with Angular 5, a JavaScript framework used by developers to build web, desktop, and mobile applications.

Author

Commented:
ok .. your script works .. only one last question .. what if i dont want to check on the first column (key) . but lets say on the last column .. what do i change in the script?

Author

Commented:
krishnakrkc?
Hi,

Try


Kris
Sub kTest()
Dim ka, k(), i As Long, n As Long, dic As Object, c As Long, q()
Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
With Range("a1")
    ka = .CurrentRegion.Offset(1).Resize(, 3).Value
    ReDim k(1 To UBound(ka, 1), 1 To 3)
    For i = 1 To UBound(ka, 1)
        If Not dic.exists(ka(i, 3)) Then '<= 3rd column of the array
            n = n + 1
            For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
            dic.Add ka(i, 3), Array(n, 3)
        Else
            q = dic.Item(ka(i, 3))
            For c = 1 To UBound(ka, 2): k(q(0), c) = ka(i, c): Next
            dic.Item(ka(i, 3)) = q
        End If
    Next
    If n > 0 Then
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Resize(n, UBound(ka, 2)).Value = k
    End If
End With
Set dic = Nothing
End Sub

Open in new window

Author

Commented:
sorry .. last question .. script works .. but i have add a few column after the 3th .. and i want to keep those

replace the following

ka = .CurrentRegion.Offset(1).Resize(, 3).Value
ReDim k(1 To UBound(ka, 1), 1 To 3)

with

ka = .CurrentRegion.Offset(1).Resize(, x).Value
ReDim k(1 To UBound(ka, 1), 1 To x)

where x is number of columns

Also adjust this line as well

dic.Add ka(i, 3), Array(n, x)

again replace x with number of columns

Kris


Author

Commented:
Thanks you!

did you have this script allready? or did you generated this script in like 5-10 minutes after reading my post?

Thanks for the feedback.

Just modified the earlier code.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial