Count(*) et Group By

L'objectif est de faire une fonction qui donne des résultats identiques aux requêtes SQL avec count(*) et group by.
On part d'une liste comme ceci :

A
aa
aa
bb
cc
cc
cc

Et on obtient ceci :

AB
aa2
aa2
bb1
cc3
cc3
cc3

Macro :

Sub Compte()
    Dim ColonneAExplorer As Integer
    ColonneAExplorer = 1
    Dim JaiTrouve  As Boolean
    JaiTrouve = True
    ActiveSheet.Cells(1, ColonneAExplorer).Select
    LigneDepart = Selection.Row
    LigneFinA = DetermineDerniereLigne(ColonneAExplorer)
    Dim LigneFinB As Integer
    For Each ColonneA In ActiveSheet.Range(Cells(1, ColonneAExplorer), Cells(LigneFinA, ColonneAExplorer))
        If ColonneA.Row = 1 Then
            ActiveSheet.Cells(1, ColonneAExplorer + 1).Value = ColonneA.Value
            ActiveSheet.Cells(1, ColonneAExplorer + 2).Value = 1
        Else
            LigneFinB = DetermineDerniereLigne(ColonneAExplorer + 1)
            For Each ColonneB In ActiveSheet.Range(Cells(1, ColonneAExplorer + 1), Cells(LigneFinB, ColonneAExplorer + 1))
                If ColonneA.Value = ColonneB.Value Then
                    ActiveSheet.Cells(ColonneB.Row, ColonneAExplorer + 2).Value = ActiveSheet.Cells(ColonneB.Row, ColonneAExplorer + 2).Value + 1
                    JaiTrouve = True
                    Exit For
                Else
                    JaiTrouve = False
                End If
            Next
            If JaiTrouve = False Then
                JaiTrouve = True
                ActiveSheet.Cells(LigneFinB + 1, ColonneAExplorer + 1).Value = ColonneA.Value
                ActiveSheet.Cells(LigneFinB + 1, ColonneAExplorer + 2).Value = 1
            End If
        End If
    Next
    ActiveSheet.Columns(ColonneAExplorer + 1).Select
    Selection.Insert Shift:=xlToRight
    ActiveSheet.Cells(1, ColonneAExplorer + 1).Select
    For Each ColonneB In ActiveSheet.Range(Cells(1, ColonneAExplorer + 2), Cells(LigneFinB, ColonneAExplorer + 2))
        For Each ColonneA In ActiveSheet.Range(Cells(1, ColonneAExplorer), Cells(LigneFinA, ColonneAExplorer))
            If ColonneA = ColonneB Then
                ActiveSheet.Cells(ColonneA.Row, ColonneA.Column + 1).Value = ActiveSheet.Cells(ColonneB.Row, ColonneB.Column + 1).Value
            End If
        Next
    Next
End Sub

Function DetermineDerniereLigne(Colonne As Integer)
    Dim LigneFin
    LigneFin = 1
    Do While Not IsEmpty(ActiveSheet.Cells(LigneFin, Colonne))
        LigneFin = LigneFin + 1
    Loop
    DetermineDerniereLigne = LigneFin - 1
End Function

Avec un tableau croisé dynamique

Dans la colonne à gauche, mettre 1 dans chaque cellule.

Mettre un titre aux deux colonnes.

Outils : Tableau croisé

Glisser la colonne des données à droite (champs de ligne).

Glisser la colonne des 1 au milieu.

Résultat :