VB Code to display and count duplicates

I am looking for a way to identify duplicates across multiple columns in excel, list each dplicate in another sheet, and display how many times each duplicate field occurs. (See attached fo desired results)

Thanks in advance.

Met

Hi Met. Try it

Sub ertert()
Dim a, b(), x, i&, n&, s$
With Sheets("Data to be compared").Range("A3").CurrentRegion
    a = .Value: ReDim b(1 To .Count, 1 To 2)
End With
On Error Resume Next
With New Collection
    For Each x In a
        s = Trim$(x)
        If Len(s) Then
            If IsEmpty(.Item(s)) Then
                i = i + 1: b(i, 1) = s: b(i, 2) = 1
                .Add i, s
            Else
                n = .Item(s): b(n, 2) = b(n, 2) + 1
            End If
        End If
    Next
End With
If i = 0 Then Exit Sub
Sheets.Add
[b1].Resize(i).NumberFormat = "#"" Times"""
[a1:b1].Resize(i).Value = b()
End Sub

Nilem:

That works! However, is there a way to exclude non-duplicated fields? Rather the entries that have a count of one? I am attaching my actual spreadsheet with your addon attached to my macro. (the macro has been executed) As you will see, my vb knowledge lacks but it works. I also want to skip the first two rows because they are titles and it would be nice to name the new sheet something, is this possible? Thans for all your help.

Adendum:

I am only interested in the fields in column A for each of the sheets. (AKA the Lawson Item #) The other fields need to be ignored. I hope my poor explaination has not confused you.

Thanks,
Met

try this

Sub Duplicate_Report()
Dim a, b(), x, i&, k, s$, wsh As Worksheet
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each wsh In ThisWorkbook.Worksheets
        If wsh.Name <> "Duplicate_Report" Then
            If Len(wsh.[a3]) Then
                With wsh
                    a = .Range("A3", .Cells(Rows.Count, 1).End(xlUp).Offset(1)).Value
                End With

                For Each x In a
                    s = Trim$(x)
                    If Len(s) Then
                        If Not .Exists(s) Then .Item(s) = 1 Else .Item(s) = .Item(s) + 1
                    End If
                Next x
            End If
        End If
    Next wsh
    ReDim b(1 To .Count, 1 To 2)
    For Each k In .keys
        If .Item(k) > 1 Then i = i + 1: b(i, 1) = k: b(i, 2) = .Item(k)
    Next
End With

If i = 0 Then MsgBox "No duplicate", 64: Exit Sub

If Not Evaluate("ISREF('Duplicate_Report'!A1)") Then
    With Sheets.Add
        .Name = "Duplicate_Report"
        .[b1].Resize(i).NumberFormat = "#"" Times"""
    End With
End If
Sheets("Duplicate_Report").[a1:b1].Resize(i).Value = b()
End Sub

Works like a charm! Kudos to both Nilem and Jindon.