Sub Мяв()
     Dim arr, i&, j&, s$
     arr = [A1].CurrentRegion.Value
     For i = 1 To UBound(arr)
         For j = 1 To UBound(arr, 2)
             s = Mid$(arr(i, j), 1, 1)
             For k = 2 To Len(arr(i, j))
                 If Mid$(arr(i, j), k, 1) < Mid$(arr(i, j), k - 1, 1) Then
                     s = Mid$(arr(i, j), k, 1) & s
                 Else
                     s = s & Mid$(arr(i, j), k, 1)
                 End If
             Next
             arr(i, j) = s
         Next
     Next
     With CreateObject("Scripting.Dictionary")
         For i = 1 To UBound(arr)
             For j = 1 To UBound(arr, 2)
                 .Item(arr(i, j)) = .Item(arr(i, j)) + 1
             Next
         Next
         For i = 1 To UBound(arr)
             For j = 1 To UBound(arr, 2)
                 If .Exists(arr(i, j)) Then
                     If .Item(arr(i, j)) > 1 Then Cells(i, j).Interior.Color = 255
                 End If
             Next
         Next
     End With
End Sub

Function st$(n)
      Dim i&, s$
      s = CStr(n)
      For i = 0 To 9: st = st & String(Len(s) - Len(Replace(s, CStr(i), "")), i): Next
End Function

Sub m()
      Dim a(), s$, x, i&, xx
      Set d = CreateObject("scripting.dictionary")
      a = Sheets("Задание_09").[a1].CurrentRegion.Value
      For Each x In a
          s = st(x)
          If d.exists(s) Then d(s) = d(s) & " " & CStr(x) Else d(s) = CStr(x)
      Next
      Sheets.Add
      For Each x In d.keys
          If InStr(d(x), " ") Then i = i + 1: xx = Split(d(x)): Cells(i, 1).Resize(, UBound(xx) + 1).Value = xx
      Next
End Sub