Find Duplicates and cut and paste it into different sheet same workbook

[silentwolf]

Hi guys,

I got a worksheet("Original") and another called ("Double")

Could someone help me with finding duplicates on column "A" on Original and find all

1232	sametext	60,00	01.01.2022
1232	sametext	56,23	01.01.2022

there can me different amount of 1232 or any text in fact.

I like to cut out all of the duplicates found based on Column A and paste them into "Double" on the last row.

Bit rusty with Excel VBA so would be appreciated some help.

Thank you very much!

As this are about 8000 records it would be great to get it in a Code running.

 

[DanteAmor]

For 8000 records the response should be immediate.

Try this:

Sub CopyDuplicate()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim a As Variant, b As Variant
  Dim dic As Object
  '
  Set dic = CreateObject("Scripting.Dictionary")
  With Sheets("Original")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    lc = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    a = .Range("A1", .Cells(lr, lc))
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  End With
 
  For i = 2 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = 0
    Else
      dic(a(i, 1)) = dic(a(i, 1)) + 1
    End If
  Next i
 
  For i = 2 To UBound(a)
    If dic(a(i, 1)) > 0 Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next i

  Sheets("Double").Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = b
End Sub

 

[silentwolf]

Hey Dante,

this works fantastic many thanks and quick for sure!

48 ms do be exact lol

Many thanks!!

Would it be possible to add that the original should delete all but one Record in the original Worksheet?

Because I like to import that updated file into Access and like to have all "ArticleNumbers in the Database but keep record of which one had double prices in it.

The Double I keep so I know which ones need to be addressed to have more then one "Price in them" So I can contact the Suplier and ask for the correct price to that particular
Article Number.

I am just not fit enough to get that working.

Many thanks

 

[DanteAmor]

Would it be possible to add that the original should delete all but one Record in the original Worksheet?

Which record to keep first or last.
Note: The process of deleting records is slower.

 

[silentwolf]

The best would be if in "Original" only remains on out of the dublicates and that records is recorded in "Doubles"

So basically if there are dublicate records in "Original" keep one of them in "Original" and put one of them into "Double" so I know it is that particular record.
Perhaps clear its price to 0,00

As the Price is incorrect or not known for this particular "Article"

So to understand it.
Following situation and prefered outcome.

I received an "Article Pricelist" in Excel. With following Columns "Artikelnummer", "Beschreibung", Preis", "Von Datum"

Many of those records include dublicates.
In the first step I delete all dublicate Records with "RemoveDuplicates on Excel.
perhaps I will include that in the code too?

However, as there are records having the same "Artikelnummer" , "Beschreibung", but different "Preis" or "Von Datum"
I need those records to be included but only once.

Maybe a simpler aproach would be to change those records the price to 0,00 and don't bother about sending it to a new sheet?

And then remove the dublicates again.

So for instance those remaining dublicates are:

Artikelnummer	Bezeichnung	Preis	Von Datum
11142	Article with Certain Description	20,33	01.01.2022
11142	Article with Certain Description	18,33	01.01.2022
11142	Article with Certain Description	19,33	01.01.2022
11142	Article with Certain Description	22,35
1112222	Another Description	12,33	01.01.2022
1112222	Another Description	123,35	01.01.2022

Now I like to have in my "Original"

11142	Article with Certain Description	0,00	01.01.2000
1112222	Another Description	0,00	01.01.2000
1021201	Price and Description where correct an all dublicates where removed in the first step by RemoveDuplicates	155,32	01.01.2022

Thinking of changing the "Preis" to 0,00 and the Date to something other then the original perhabs 01.01.2000 so I can differentiate from the others.

Then I import those Records to Access with no Dublicates in "Artiklenummer"

So the "double" Worksheet was for me to visualize the duplicate records and is not really needed if only one record will remain in the "Original" Worksheet with "Preise" set to 0,00 and perhabs the Date changed to "01.01.2000" of all those who are not beeing removed by RemoveDuplicates. But only one record should remain as shown above.

Sorry for changing it from the original logic but I guess that would be the perfect aproach to this and would be fantastic if that could be worked out by code.

Many thanks for your help!

 

[DanteAmor]

So in summary:
1. Remove duplicate records.
2. Do not copy to the other sheet.
3. The record that remains changes the "Preise" to 0 and the date to "01.01.2000"
Correct?

 

[silentwolf]

Hi yes DanteAmor,
that is correct.



would that be ok to change?

Cheers

 

[DanteAmor]

Try this:

Sub RemoveDuplicate()
  Dim i As Long, lr As Long, n As Long, m As Long
  Dim c As Range, r As Range
  
  lr = Range("A" & Rows.Count).End(3).Row
  Set r = Range("A" & lr + 1)
  For Each c In Range("A2", Range("A" & Rows.Count).End(3))
    n = WorksheetFunction.CountIf(Range("A2:A" & c.Row), c.Value)
    m = WorksheetFunction.CountIf(Range("A2:A" & lr), c.Value)
    If m > 1 Then
      If n = 1 Then
        c.Offset(, 2).Value = 0
        c.Offset(, 3).Value = "01.01.2000"
      Else
        Set r = Union(r, c)
      End If
    End If
  Next
  If Not r Is Nothing Then r.EntireRow.Delete
End Sub

 

[silentwolf]

Hey DanteAmor,

This is fantastic!!

I checked with Access and there are no duplicates in that List so I asume that is all pretty well and fine!

So I believe it should work correctly.

Many many thanks!

Cheers

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.