XL 2016 Trie d'information dans des cellules

Sub dispatch()
Dim TabData() As Variant

With Sheets("Base")
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row 'derniere ligne sur la colonne A
    TabData = .Range("A2:C" & Fin).Value
End With

Col = 1
With Sheets("Colonne1")
    .UsedRange.Offset(1, 0).ClearContents
    For i = LBound(TabData, 1) To UBound(TabData, 1)
        nbligne = UBound(Split(TabData(i, 2), ",")) + 1
        If nbligne = 0 Then
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
        Else
            For k = 1 To nbligne
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, Col + 1), ",")(k - 1)
            Next k
        End If
    Next i
End With

Col = 2
With Sheets("Colonne2")
    .UsedRange.Offset(1, 0).ClearContents
    For i = LBound(TabData, 1) To UBound(TabData, 1)
        nbligne = UBound(Split(TabData(i, 3), ",")) + 1
        If nbligne = 0 Then
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
        Else
            For k = 1 To nbligne
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, Col + 1), ",")(k - 1)
            Next k
        End If
    Next i
End With
End Sub

Sub dispatch()
Dim TabData() As Variant

With Sheets("Base")
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row 'derniere ligne sur la colonne A
    TabData = .Range("A2:C" & Fin).Value
End With

For col = 1 To 2
    NomFeuille = "Colonne" & col
    With Sheets(NomFeuille)
        .UsedRange.Offset(1, 0).ClearContents
        For i = LBound(TabData, 1) To UBound(TabData, 1)
            nbligne = UBound(Split(TabData(i, col + 1), ",")) + 1
            If nbligne = 0 Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
            Else
                For k = 1 To nbligne
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                    .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, col + 1), ",")(k - 1)
                Next k
            End If
        Next i
    End With
Next col

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim col%, nlig&, resu(), tablo, i&, nom$, s, ub%, j%, n&, x$, p%
col = Val(Replace(LCase(Sh.Name), "colonne", ""))
If col = 0 Then Exit Sub
col = col + 1
With Sheets("Base").[A1].CurrentRegion
    tablo = .Resize(, col) 'matrice, plus rapide
    .Columns(col).Name = "Colonne" 'plage nommée
    nlig = .Rows.Count + [SUM(LEN(Colonne)-LEN(SUBSTITUTE(Colonne,",",)))]
End With
ReDim resu(1 To nlig, 1 To 2) 'tableau des résultats
For i = 1 To UBound(tablo)
    nom = tablo(i, 1)
    s = Split(tablo(i, col), ",")
    ub = UBound(s)
    If ub = -1 Then n = n + 1: resu(n, 1) = nom
    For j = 0 To ub
        n = n + 1
        resu(n, 1) = nom
        x = Trim(s(j))
        p = InStr(x, ";")
        If p Then x = RTrim(Left(x, p - 1)) 'texte avant le point-virgule
        resu(n, 2) = x
Next j, i
'---restitution---
With Sh.[A1] '1ère cellule de restitution
    .Resize(n, 2) = resu
    .Offset(n).Resize(Sh.Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub