VBA - Copy All Duplicate Data (Including first instance)

[FeedbackNoob]

Hi guys,

I've just started a new role and I need to find all duplicates in data over the past 6 months as my predecessor hadn't been doing this, and the idea of doing it manually for 8000 lines of data is terrifying me. Can anyone help me with VBA code to pull all duplicates into another spreadsheet?

My file looks something like the following, with around 30 columns and 8000 rows of data.

[TABLE="width: 900"]
<tbody>[TR]
[TD]Identifier Number[/TD]
[TD]Business Name[/TD]
[TD]Account Manager[/TD]
[TD]Business Type[/TD]
[TD]Contact Reason[/TD]
[TD]Date of Contact[/TD]
[/TR]
[TR]
[TD]12345[/TD]
[TD]Bobs Bacon[/TD]
[TD]Johnny Jones[/TD]
[TD]Food Outlet[/TD]
[TD]Pricing[/TD]
[TD]01/01/2018[/TD]
[/TR]
[TR]
[TD]82654[/TD]
[TD]Sarah's Shellfish[/TD]
[TD]Jack Daniels[/TD]
[TD]Food Outlet[/TD]
[TD]Lack of contact[/TD]
[TD]06/04/2018[/TD]
[/TR]
[TR]
[TD]48572[/TD]
[TD]Connors Corner Store[/TD]
[TD]Jim Smith[/TD]
[TD]Convenience[/TD]
[TD]Customer service[/TD]
[TD]09/08/2018[/TD]
[/TR]
[TR]
[TD]12345[/TD]
[TD]Bobs Bacon[/TD]
[TD]Johnny Jones[/TD]
[TD]Food Outlet[/TD]
[TD]Damaged stock[/TD]
[TD]11/09/2018[/TD]
[/TR]
</tbody>[/TABLE]

What I need is to find all duplicates of the identifier number (even if the rest don't match) which is in Column B in my worksheet, and then pull the whole row of data into another spreadsheet, so I can follow up on why these duplicates exist.

For example in the table above 12345 Bobs Bacon occurs twice with a different contact reason but I would need to pull both of these into another sheet.

I've tried doing this with a pivot table but it doesn't really work for me, and I've found and tweaked some macros online, but they ignore the first instance and just pull those listed after the first. I don't know enough to be sure on how to change this.

Any help, even just pointing me in the right direction on how to do this would be amazing. Thank you in advance

 

[footoo]

Here's a manual way :
• In a blank column, enter =IF(COUNTIF(A:A,A1)=1,1,2) and fill down
• Sort by this column and all the duplicated ID Nbrs will be at the bottom

 

[JefferyLi]

Try this. Just make sure to change all the "YOUR NAME" to your worksheet's name

Sub Test()


Dim source As Worksheet, destination As Worksheet
Dim i As Long

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Duplicate"

Set source = ThisWorkbook.Worksheets("YOUR NAME")
Set destination = ThisWorkbook.Worksheets("Duplicate")

Sheets("YOUR NAME").Activate


Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("B2").Value = "=COUNTIF(A:A,A2)"

Range("B2").Select
Selection.AutoFill destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)

Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A1").EntireRow.Select
Selection.Copy destination:=Sheets("Duplicate").Range("A1")

For i = 2 To source.Cells(source.Rows.Count, "B").End(xlUp).Row
If source.Range("B" & i).Value > 1 Then
source.Range("A" & i).EntireRow.Copy destination.Range("A" & destination.Cells(destination.Rows.Count, "B").End(xlUp).Row + 1)
source.Range("A" & i).EntireRow.EntireRow.Delete
End If
Next i

Sheets("YOUR NAME").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

Sheets("Duplicate").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

End Sub

 

[footoo]

If a macro is required, it would be more efficient to base it on the steps per post # 2 :

Sub Test()
Dim source As Worksheet, dest As Worksheet, rng As Range
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Duplicate"
Set dest = ThisWorkbook.Worksheets("Duplicate")
Set source = ThisWorkbook.Worksheets("YOUR NAME") 'Change name as required
source.Activate
[A:A].Insert
Rows(1).Copy dest.Rows(1)
Set rng = Range("A2:A" & Cells(Rows.Count, "B").End(3).Row)
rng.Formula = "=IF(COUNTIF(B:B,B2)=1,1,""a"")"
With source.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=rng(1), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange rng.EntireRow
    .Header = xlNo
    .Apply
End With
With [A:A].SpecialCells(xlCellTypeFormulas, 2).EntireRow
    .Copy dest.[A2]
    .Delete
End With
[A:A].Delete
dest.[A:A].Delete
End Sub