2 column condition move duplicates to new sheet

[Danny69]

Hi,
Below code is working perfectly for moving duplicates from single column A to sheet Duplicate, Now i want to add column B also as condition to find duplicates. Column A & B if duplicates then move rows to sheet Duplicate. Column A contains numbers stored as Text and Column B contains Text (Name).

Sub CUT_Dupes_New_Sheet()
    On Error GoTo ErrHandler
    Dim myDataRng As Range, myCutRng As Range
    Dim c As Range, cc As Range
    Dim lCol As Long
    Set myDataRng = Range("A2:A" & Cells(Rows.Count, "I").End(xlUp).Row)
    Application.ScreenUpdating = False
    For Each c In myDataRng
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & c.Address & ")") > 1 Then
            lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
            c.Offset(, 17) = "xx"
        End If
    Next c
     Set myCutRng = Range("R2:R" & Cells(Rows.Count, "I").End(xlUp).Row)
    For Each cc In myCutRng
        If cc = "xx" Then
            cc.Offset(, -17).Resize(1, 17).Cut Sheets("Duplicates").Range("A" & Rows.Count).End(xlUp)(2)
        End If
    Next cc
    Set myDataRng = Nothing
    Range("R:R").ClearContents
ErrHandler:
    Application.ScreenUpdating = True
End Sub

[大灰狼1976]

Hi Danny!
Something like below. Untested.

Sub CUT_Dupes_New_Sheet()
    Dim myDataRng As Range, myCutRng As Range, d As Object, s$, r&, c As Range
    Set myDataRng = Range("A2:A" & Cells(Rows.Count, "I").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    For Each c In myDataRng
        s = c & "," & c.Offset(, 1)
        If d.exists(s) Then
            If myCutRng Is Nothing Then Set myCutRng = c.Resize(, 17) Else myCutRng = Union(myCutRng, c.Resize(, 17))
        End If
        d(s) = ""
    Next c
    If Not myCutRng Is Nothing Then myCutRng.Cut Sheets("Duplicates").Range("A" & Rows.Count).End(xlUp)(2)
    
    Set myDataRng = Nothing
    Set myCutRng = Nothing
End Sub

[p45cal]

or:

Sub CUT_Dupes_New_Sheet2()
On Error GoTo ErrHandler
Dim myDataRng As Range, myCutRng As Range
Dim c As Range, cc As Range
Dim lCol As Long, lr As Long

lr = Cells(Rows.Count, "I").End(xlUp).Row
Set myDataRng = Range("A2:A" & lr)
Application.ScreenUpdating = False
With myDataRng.Offset(, 17)
  .FormulaR1C1 = "=IF(COUNTIFS(R2C1:R" & lr & "C1,RC[-17],R2C2:R" & lr & "C2,RC[-16])>1,""xx"","""")"
  .Value = .Value
  For Each cc In .Cells
    If cc = "xx" Then
      cc.Offset(, -17).Resize(1, 17).Cut Sheets("Duplicates").Range("A" & Rows.Count).End(xlUp)(2)
    End If
  Next cc
  .ClearContents
End With
Set myDataRng = Nothing
ErrHandler:
Application.ScreenUpdating = True
End Sub

[Danny69]

​Hi,
Thanks p45cal its perfect, one more thing i want to add on sheet Duplicates Column B (name) & Column F (amount) to sum the amount of each duplicate group.


Col_B .Col F.. __Total
xxxx ....100.00
xxxx ....500.00
xxxx 90000.00
xxxx...4321.00
xxxx ..1213.00..96134.00
yy....17454.00
yy ...98900.00 211888.00


Thanks in advance.

[p45cal]

At this stage I'd like to see a representative workbook - can you attach one? It's hard work guessing/working out how your data is organised, and I'll probably guess wrongly anyway - I've closed, without saving, what I used to provide the snippet of code earlier.

I don't really understand why you're doing what you're doing - there are easier ways of summarising the data, and more reliably - such as with a couple of (or only one) pivot tables.

[Danny69]

Hi,

Sample workbook uploaded.
Book1.xlsx

[p45cal]

There's only sheet Duplicates in that file.

[Danny69]

Hi,

There's only sheet Duplicates in that file.

New sample data uploaded.
Thanks

[p45cal]

There's still only one sheet in that file.

[p45cal]

In the Duplicates sheet you can get the information you need by going to the Data tab, Outline section, then choose Subtotal, and do something like:
2020-03-22_132011.jpg
but you will probably need to sort on column B if duplicates there aren't next to each other.

I don't really understand why you want to separate out duplicates from unique values…

[Danny69]

Hi,

I did not understood your point, now file uploaded with data.

Thanks

[p45cal]

Is this the sort of information you want to end up with?:

2020-03-22_153854.jpg

[Danny69]

Hi,
Yes p45cal

Thanks for your efforts.

[p45cal]

Yes

Then you don't need macros, subtotals etc. just a straightforward pivot table which takes less than 30 secs to set up. See attached.

[Danny69]

Hi,
Thanks a lot. p45cal