Sub мяу()
    Dim arr, sh As Worksheet, i&, j&, a
    With CreateObject("Scripting.Dictionary")
        For Each sh In Worksheets
            arr = sh.UsedRange.Value
            For i = LBound(arr) To UBound(arr)
                For j = LBound(arr, 2) To UBound(arr, 2)
                  If Len(arr(i, j)) Then .Item(arr(i, j)) = .Item(arr(i, j)) + 1
                Next
            Next
        Next
        arr = .Keys
        For Each a In arr
            If .Item(a) = 1 Then .Remove (a)
        Next
        Set sh = Worksheets.Add
        sh.Range("A1").Resize(.Count) = Application.Transpose(.Keys)
    End With
End Sub

Sub мяв()
    Dim arr, sh As Worksheet, i&, j&
    Dim oDik1 As Object, oDik2 As Object
    Set oDik1 = CreateObject("Scripting.Dictionary")
    Set oDik2 = CreateObject("Scripting.Dictionary")
    For Each sh In Worksheets
        arr = sh.UsedRange.Value
        For i = LBound(arr) To UBound(arr)
            For j = LBound(arr, 2) To UBound(arr, 2)
                If Len(arr(i, j)) Then
                    If oDik1.Exists(arr(i, j)) Then
                        oDik2.Item(arr(i, j)) = 1
                    Else
                        oDik1.Item(arr(i, j)) = oDik1.Item(arr(i, j)) + 1
                    End If
                End If
            Next
        Next
    Next
    Set sh = Worksheets.Add
    sh.Range("A1").Resize(oDik2.Count) = Application.Transpose(oDik2.Keys)
End Sub