Listing de tag et de leur occurences

Sub ListerTags()
    Dim c As Range
    Dim t, i
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Tags")
        For Each c In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
            t = Split(c, ";")
            If UBound(t) > -1 Then
                For i = LBound(t) To UBound(t)
                    dic.Item(t(i)) = t(i)
                Next i
            End If
        Next c
    End With
    If dic.Count > 0 Then
        With Sheets("Occurence").Range("A2").Resize(dic.Count)
            .Value = Application.Transpose(dic.keys)
            .Offset(, 1).Formula = "=COUNTIF(Tags!$A$2:$A$" & Sheets("Tags").Cells(Rows.Count, 1).End(xlUp).Row & ",""*""&Occurence!A2&""*"")"
        End With
    End If
End Sub