VBA Script - Search multiple sheets for duplicates and paste onto new sheet

[stitchoz]

Good Afternoon,

I have searched a few things before creating this post so I apologize in advance if this was already done. The ones I have seen perform somewhat of what I'm trying to do, but not to the exact and my VBA/Formatting/Pivot knowledge is very very minimal.

What I'm trying to do is I have multiple sheets with account numbers, I'm trying to search all sheets and if they show up 3 or more times then the account name and number is pasted onto the new sheet. Column A is the account number Column B is the account name. I want to where it would post those accounts onto a new sheet, and if possible the number of times they showed up as well into column C.

I have tried using conditional formatting but it has a limit of 3 conditions. So I figure maybe a VBA of some kind could do this for me. Please advise, I thank you so much in advance for helping a beginner out.

 

[JLGWhiz]

this is sort of clunged, but seems to work.

Sub acctDup()
Dim sh As Worksheet, sumsh As Worksheet, lr As Long, c As Range, cnt As Long, i As Long, rng As Range
Sheets.Add Before:=ThisWorkbook.Sheets(1)
Set sumsh = ActiveSheet
sumsh.Range("A1:A2") = "x"
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> sumsh.Name Then
            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
            sh.Range("A2:B" & lr).Copy sumsh.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
Set rng = sumsh.Range("A3", sumsh.Cells(Rows.Count, 1).End(xlUp))
    With sumsh
        For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
            If Application.CountIf(rng, .Cells(i, 1).Value) < 3 Then
                Rows(i).Delete
            Else
                .Range("A2", .Cells(Rows.Count, 2).End(xlUp)).AutoFilter 1, .Cells(i, 1).Value
                cnt = rng.SpecialCells(xlCellTypeVisible).Count
                If cnt >= 3 Then
                    .Cells(i, 3) = cnt
                    .Range("A3", .Cells(i - 1, 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End If
                .AutoFilterMode = False
                i = i + 1 - cnt
                cnt = 0
            End If
        Next
    End With
End Sub

Copy the code to your standard code module 1.

 

[stitchoz]

Thank you!!!! I got about 100 results and I think its pretty accurate as there shouldn't be that many results. I'll double check each one cause now there is only 72 accounts to review. This made my work a ton easier!!!!

 

[JLGWhiz]

Thank you!!!! I got about 100 results and I think its pretty accurate as there shouldn't be that many results. I'll double check each one cause now there is only 72 accounts to review. This made my work a ton easier!!!!

You're welcome,
Regards, JLG