Lister et calculer le nombre de récurrence (VBA)

Sub Bilan()
 
    Dim Dico As Object
    Dim DicoMois As Object
    Dim Valeur As Variant
    Dim Cle As Variant
    Dim Plage As Range
    Dim I As Integer
    Dim J As Integer
    Dim Nom As String
    Dim Tbl
    
    'création du dictionnaire
    Set Dico = CreateObject("Scripting.Dictionary")
    
    'la plage se situe en feuille "Exemple" (adapter le nom si il change)
    'et en colonne A en partant de A2
    With Worksheets("Exemple")
    
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    
    End With
    
    'Parcour la plage
    For I = 1 To Plage.Count
    
        'concatène les cellules des colonnes A et B
        'afin de pouvoir extraire les doublons avec le dico
        Nom = Plage(I) & ";" & Plage(I).Offset(0, 1)
        
        'si la concaténation des deux mots n'existe pas, elle est rajoutée au dico
        'avec une valeur de 1 puisque c'est la première occurence trouvée
        If Dico.exists(Nom) = False Then
        
            Dico.Add Nom, 1
        
        'dans le cas contraire, on incrémente
        Else
        
            Dico(Nom) = Dico(Nom) + 1
            
        End If
        
    Next I
    
    'récup dans les variables des clés et valeurs
    Valeur = Dico.Items
    Cle = Dico.keys
    
    'crée un second dictionnaire pour le tri des mois
    Set DicoMois = CreateObject("Scripting.Dictionary")
    
    'parcour le dico 1
    For I = 0 To Dico.Count - 1
        
        'splite la clé afin de récupérer le mois et le fruit
        Tbl = Split(Cle(I), ";")
                
        With Worksheets("Feuille de bilan")
            
            'si le mois n'est pas encore dans le dico :
            If DicoMois.exists(Tbl(0)) = False Then
            
                DicoMois.Add Tbl(0), Tbl(0) 'ajout
                
                J = J + 3 'saut de ligne
                
                .Range("A" & J) = Tbl(0) 'mois
                .Range("A" & J).Font.Bold = True 'en gras
                .Range("A" & J & ":" & "B" & J).Merge 'fusion
                .Range("A" & J & ":" & "B" & J).HorizontalAlignment = xlCenter 'centrage
                
                J = J + 1 'passe à la ligne suivante
                
                .Range("A" & J) = Tbl(1) 'fruit
                .Range("B" & J) = Valeur(I) 'nombre
            
            'dans le cas contraire, ne fait que de rajouter les fruits suivants au mois en cours
            Else
            
                J = J + 1
                
                .Range("A" & J) = Tbl(1)
                .Range("B" & J) = Valeur(I)
            
            End If

        End With
        
    Next I

End Sub

Option Explicit
Dim coll As New Collection
Dim C As Range, sh As Worksheet

Dim i As Long, i1 As Long
Dim M As Long
Dim N As Long
Dim lig As Long, ligd As Long
Dim Temp As String
Dim FirstAddress As String

Sub travdem()
Dim coll2 As New Collection
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim Nomfeuille2 As String
Dim mois1 As String
' pour boucler sur la colonne 1
Nomfeuille1 = "Exemple"
Nomfeuille2 = "Feuille de bilan"
' chercher les mois
With Sheets(Nomfeuille1)
    On Error Resume Next
    For Each Cellule In .Range("a2:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
        coll2.Add Cellule.Value, CStr(Cellule.Value)
    Next Cellule
    On Error GoTo 0

End With
lig = 3
ligd = lig
With Sheets(Nomfeuille2)
' pour chaque mois on cherche les fruits
For i1 = 1 To coll2.Count
    If coll2(i1) <> "" Then
        mois1 = coll2(i1)
        Sheets(Nomfeuille2).Range("b" & lig) = mois1
        lig = lig + 1
        Call trouveritem(Nomfeuille1, mois1)
        Call ecriture(Nomfeuille2)
        lig = lig + 1
        Set coll = New Collection
        For Each Cellule In .Range("a" & ligd & ":a" & lig)
            If Cellule <> "" Then Cellule.Offset(0, 1) = compteritem(Nomfeuille1, mois1, Cellule.Value)
        Next Cellule
        ligd = lig
   End If
Next i1
   End With
End Sub

' trouver les fruits
Private Sub trouveritem(Nomfeuille1 As String, data1 As String)
With Sheets(Nomfeuille1)
On Error Resume Next
    With .Range("a1:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
        Set C = .Find(data1, LookIn:=xlValues, LookAt:=xlWhole)
        If Not C Is Nothing Then
            FirstAddress = C.Address
            Do
                coll.Add C.Offset(0, 1), CStr(C.Offset(0, 1))
                Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> FirstAddress
        End If
    End With
End With
End Sub

' trier les fruits
Private Sub ecriture(Nomfeuille2 As String)
Dim Listdata() As String
ReDim Listdata(coll.Count - 1)
For i = 0 To coll.Count - 1
    If coll(i + 1) <> "" Then Listdata(i) = coll(i + 1)
Next i
For N = 0 To UBound(Listdata)
    For M = 0 To UBound(Listdata)
       If Listdata(M) > Listdata(N) Then
          Temp = Listdata(N)
          Listdata(N) = Listdata(M)
          Listdata(M) = Temp
       End If
    Next M
Next N
With Sheets(Nomfeuille2)
For N = 0 To UBound(Listdata)
If Listdata(N) <> "" Then
.Range("a" & lig) = Listdata(N)
lig = lig + 1
End If
Next N

End With
End Sub

' compter les fruits
Private Function compteritem(Nomfeuille1 As String, data1 As String, data3 As String)
With Sheets(Nomfeuille1)
On Error Resume Next
    With .Range("a1:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
        Set C = .Find(data1, LookIn:=xlValues, LookAt:=xlWhole)
        If Not C Is Nothing Then
            FirstAddress = C.Address
            Do
                If C.Offset(0, 1) = data3 Then compteritem = compteritem + 1
                    
                Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> FirstAddress
        End If
    End With
End With
End Function

Sub test()
Dim c As Range, d As Range
Const Mois As String = "Janvier Février Mars Avril Mai Juin Juillet Août Septembre Octobre Novembre Décembre"
M = Split(Mois)
Set d = Feuil2.Range("A2")
For t = LBound(M) To UBound(M)
  Set c = Range("A:A").Find(what:=M(t), LookIn:=xlValues, lookat:=xlWhole)
  Set d = d.Offset(1)
  If Not c Is Nothing Then
    With Feuil2
      Do While c = M(t)
        'Nouveau mois ?
        If IsError(Application.Match(M(t), .Range("A:A"), 0)) Then d = M(t): d.Resize(, 2).Merge: d.HorizontalAlignment = xlCenter: d.Font.Bold = True: Set d = d.Offset(1)
        'si Nouveau fruit dans ce mois, on l'ajoute à la suite
        If IsError(Application.Match(c.Offset(, 1), Feuil2.Range("A" & Application.Match(M(t), Feuil2.Range("A:A"), 0) & ":A" & d.Row), 0)) Then
          d = c.Offset(, 1)
          d.Offset(, 1) = 1
          Set d = d.Offset(1)
        'Sinon on ajoute 1...
        Else
          .Cells(Application.Match(c.Offset(, 1), .Range("A" & Application.Match(M(t), .Range("A:A"), 0) & ":A" & d.Row), 0) + Application.Match(M(t), .Range("A:A"), 0) - 1, 2) = _
          .Cells(Application.Match(c.Offset(, 1), .Range("A" & Application.Match(M(t), .Range("A:A"), 0) & ":A" & d.Row), 0) + Application.Match(M(t), .Range("A:A"), 0) - 1, 2) + 1
        End If
        Set c = c.Offset(1)
      Loop
    End With
  End If
Next t
set c=Nothing: Set d=Nothing
End Sub

Sub test2()
Dim c As Range, d As Range, cel As Range, nVal As Integer
Set c = Range("C2"): Set d = Feuil2.Range("A3")
nVal = Application.CountA(Range("A:A")) - 1
c.Resize(nVal).FormulaR1C1 = "=RC[-2]&RC[-1]"
With c.Offset(, 1).Resize(nVal)
 .FormulaR1C1 = "=IF(COUNTIF(R2C[-1]:RC[-1],RC[-1])=1,COUNTIF(R2C[-1]:R[" & nVal - 1 & "]C[-1],RC[-1]),"""")"
 .Value = .Value
  For Each cel In .SpecialCells(xlCellTypeConstants, xlNumbers)
    If cel.Offset(, -3) <> cel.Offset(-1, -3) Then Set d = d.Offset(1): d = cel.Offset(, -3): d.Resize(, 2).Merge: d.HorizontalAlignment = xlCenter: d.Font.Bold = True: Set d = d.Offset(1)
    d = cel.Offset(, -2)
    d.Offset(, 1) = cel
    Set d = d.Offset(1)
  Next cel
End With
c.Resize(nVal, 2).ClearContents
End Sub