• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to delete duplicates together with the original rows using excel vba

gift

gift

New Member
HI all

I was hoping someone could help me. I have an excel file with rows that are duplicated and all I want to do is delete those rows together with the originals, so what is left are entries that were unique from the firs place. Please see attached.

Thanks in advance.

Gift
 

Attachments

  • Duplicates and original.xlsx
    10.1 KB · Views: 22
Code: 
Sub test()
    Dim a, i As Long, txt As String, e
    a = Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            If Not .exists(txt) Then
                .Item(txt) = Application.Index(a, i, 0)
            Else
                .Item(txt) = Empty
            End If
        Next
        For Each e In .keys
            If IsEmpty(.Item(e)) Then .Remove e
        Next
        a = Application.Index(.items, 0, 0)
    End With
    [m1].Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
 
jindon said:
Code: 
Sub test()
    Dim a, i As Long, txt As String, e
    a = Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            If Not .exists(txt) Then
                .Item(txt) = Application.Index(a, i, 0)
            Else
                .Item(txt) = Empty
            End If
        Next
        For Each e In .keys
            If IsEmpty(.Item(e)) Then .Remove e
        Next
        a = Application.Index(.items, 0, 0)
    End With
    [m1].Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
Click to expand...


Hi Jindon,

Thank you so much for your reply. This works well. Thing is it is pasting the desired data in cell M1, what I need is for the macro to delete those the unwanted rows in the original location and leave the unique entries there.

Any ideas?

Thank you.
 
Then
Code: 
Sub test()
    Dim a, i As Long, txt As String, e
    With Cells(1).CurrentRegion
        a = .Value: .ClearContents
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = Application.Index(a, i, 0)
                Else
                    .Item(txt) = Empty
                End If
            Next
            For Each e In .keys
                If IsEmpty(.Item(e)) Then .Remove e
            Next
            a = Application.Index(.items, 0, 0)
        End With
        .Resize(UBound(a, 1)).Value = a
    End With
End Sub
 
jindon said:
Then
Code: 
Sub test()
    Dim a, i As Long, txt As String, e
    With Cells(1).CurrentRegion
        a = .Value: .ClearContents
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = Application.Index(a, i, 0)
                Else
                    .Item(txt) = Empty
                End If
            Next
            For Each e In .keys
                If IsEmpty(.Item(e)) Then .Remove e
            Next
            a = Application.Index(.items, 0, 0)
        End With
        .Resize(UBound(a, 1)).Value = a
    End With
End Sub
Click to expand...


100%... Perfect!! Sooo excited thank you!!!
 
jindon said:
Then
Code: 
Sub test()
    Dim a, i As Long, txt As String, e
    With Cells(1).CurrentRegion
        a = .Value: .ClearContents
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = Application.Index(a, i, 0)
                Else
                    .Item(txt) = Empty
                End If
            Next
            For Each e In .keys
                If IsEmpty(.Item(e)) Then .Remove e
            Next
            a = Application.Index(.items, 0, 0)
        End With
        .Resize(UBound(a, 1)).Value = a
    End With
End Sub
Click to expand...


Hey Jindon,

Sorry to bother once more, but I tried to use this code in another excel with the same set up, only difference is there are shapes in one cell in each row and the code doesn't seem to work. I was hoping you could modify it for me. Please see attached to get more clarity.

Thank you so much.
 

Attachments

  • Delete rows1.xlsm
    37.9 KB · Views: 8
Nowhere near to the original set up.
Code: 
Sub test()
     Dim a, i As Long, txt As String, x As Range, dic As Object
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     With Range("b8", Range("b" & Rows.Count).End(xlUp)).Resize(, 3)
         a = .Value
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            If Not dic.exists(txt) Then
                Set dic(txt) = .Rows(i)
            Else
                If x Is Nothing Then
                    Set x = Union(dic(txt), .Rows(i))
                Else
                    Set x = Union(x, dic(txt), .Rows(i))
                End If
            End If
        Next
        If Not x Is Nothing Then x.EntireRow.Delete
     End With
End Sub
 
jindon said:
Nowhere near to the original set up.
Code: 
Sub test()
     Dim a, i As Long, txt As String, x As Range, dic As Object
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     With Range("b8", Range("b" & Rows.Count).End(xlUp)).Resize(, 3)
         a = .Value
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            If Not dic.exists(txt) Then
                Set dic(txt) = .Rows(i)
            Else
                If x Is Nothing Then
                    Set x = Union(dic(txt), .Rows(i))
                Else
                    Set x = Union(x, dic(txt), .Rows(i))
                End If
            End If
        Next
        If Not x Is Nothing Then x.EntireRow.Delete
     End With
End Sub
Click to expand...

Hi Jindon,

Thank you so much. This works perfect, but just one other thing, So I have an excel with a few sheets, similar to the one I sent recently, only that the data in each sheet does not begin in row 8, some start in row 10 and some 12 and so on.How do I modify the code for those specific sheets. Also note that some don't have the circles(shapes), its just text.

Thanks so much. I am so close to getting this done.
 
jindon said:
Need to see your workbook with 2-3 worksheets.
Click to expand...


Please see attached. The maximum columns in a sheet in my workbook is 10, and I have included that sheet on the file attached. If you can, please create a loop so that it runs the code once and keep it clean. the loop must select the sheets where it performs the code. not all the sheets in my workbook need this to be done.

Thanks again.
 

Attachments

  • Worksheets.xlsx
    42.1 KB · Views: 10
Try
Code: 
Sub test()
     Dim e, a, i As Long, txt As String, x As Range, dic As Object
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     For Each e In Array(Array("status", 8), Array("results", 11), Array("open findins", 12))
        With Sheets(e(0))
            With .Range("b" & e(1), .Range("b" & Rows.Count).End(xlUp)).Resize(, 3)
                a = .Value
               For i = 1 To UBound(a, 1)
                   txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                   If Not dic.exists(txt) Then
                       Set dic(txt) = .Rows(i)
                   Else
                       If x Is Nothing Then
                           Set x = Union(dic(txt), .Rows(i))
                       Else
                           Set x = Union(x, dic(txt), .Rows(i))
                       End If
                   End If
               Next
               If Not x Is Nothing Then x.EntireRow.Delete
               dic.RemoveAll: Set x = Nothing
            End With
        End With
    Next
End Sub
 
Hi Jindon,

this code only works for the first sheet only. It deletes everything in the second sheet and the third one aswel and leaves the ovals.
 
There are 2 unique entries in each of the sheets. The "Client Coverage entries are unique in each sheet.
 
How unique are they?

You have 2 rows of "Client Coverage" entry on Co.B with Col.C & D blank in each sheet.
 
They are not blank. the first columns are blank but the last one is populated. it is supposed to look across the entire row, not based on only one. The commentary colums are populated with information. Also is the last sheet the shapes still remain after I run the code.
 
1) Why you have such inconsistent messy structured worksheets?
Can you not re-construct them.

2) Are you intentionally entering meaningless letter such like "a" "h" "aa" in a blank row above the heading?
If you have a good reason for 2), just tell me, because it IS creating a problem.
 
You must log in or register to reply here.
Back
Top