Compter nombre de cellule carateres identiques

Sub Comptage()
Dim d As Object, cel As Range, n As Variant
Application.ScreenUpdating = False
[E3:F65536].ClearContents
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Range([A2], [A65536].End(xlUp))
If Not d.Exists(cel.Value) And cel <> "" Then d.Add cel.Value, CStr(cel.Value)
Next
[E3].Resize(d.Count, 1) = Application.Transpose(d.items)
For Each cel In Range([E3], [E65536].End(xlUp))
cel.Offset(, 1) = Application.CountIf([A:A], cel)
Next
[E3:F65536].Sort Key1:=[F3], Order1:=xlDescending, Header:=xlNo
n = Application.Match([C3], [F:F], -1)
If IsError(n) Then n = 2
Range("E" & n + 1, [F65536]).ClearContents
End Sub

Sub Comptage()
Dim d As Object, ws As Worksheet, cel As Range, n As Variant
Application.ScreenUpdating = False
[E3:F65536].ClearContents
Set d = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
  With ws
    If .Index < 6 Then
      For Each cel In .Range(.[A2], .[A65536].End(xlUp))
        If Not d.Exists(cel.Value) And cel <> "" Then d.Add cel.Value, CStr(cel.Value)
      Next
    End If
  End With
Next
[E3].Resize(d.Count) = Application.Transpose(d.items)
For Each cel In Range([E3], [E65536].End(xlUp))
  For Each ws In Worksheets
    With ws
      If .Index < 6 Then cel.Offset(, 1) = Application.CountIf(.[A:A], cel) + cel.Offset(, 1)
    End With
  Next
Next
[E3:F65536].Sort Key1:=[F3], Order1:=xlDescending, Header:=xlNo
n = Application.Match([C3], [F:F], -1)
If IsError(n) Then n = 2
Range("E" & n + 1, [F65536]).ClearContents
End Sub

Sub Comptage()
Dim d As Object, ws As Worksheet, cel As Range, n As Variant
Application.ScreenUpdating = False
[E3:K65536].ClearContents
Set d = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
  With ws
    If .Index < 6 Then
      For Each cel In .Range(.[A2], .[A65536].End(xlUp))
        If Not d.Exists(cel.Value) And cel <> "" Then d.Add cel.Value, CStr(cel.Value)
      Next
    End If
  End With
Next
[E3].Resize(d.Count) = Application.Transpose(d.items)
For Each cel In Range([E3], [E65536].End(xlUp))
  For Each ws In Worksheets
    With ws
      If .Index < 6 Then
        n = Application.CountIf(.[A:A], cel)
        cel.Offset(, 1) = n + cel.Offset(, 1)
        cel.Offset(, .Index + 1) = n
      End If
    End With
  Next
Next
[E3:K65536].Sort Key1:=[F3], Order1:=xlDescending, Header:=xlNo
n = Application.Match([C3], [F:F], -1)
If IsError(n) Then n = 2
Range("E" & n + 1, [K65536]).ClearContents
End Sub

[E3].Resize(d.Count) = Application.Transpose(d.items)