Séparer des contacts dans une même cellule et compter leur valeur associée

Option Explicit
Sub test1()
Dim c As Range, Item As Variant, Ligne As Long, Plage As Range, Ctr As Integer
    Ligne = 1
    With Sheets("Feuil1")
        Set Plage = .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
        For Each c In Plage
            Ctr = c.Offset(, -1).Value
            If c.Value <> "" Then
                For Each Item In Split(c.Value, "; ")
                    Ligne = Ligne + 1
                    If Ctr <> 0 Then
                        .Cells(Ligne, 2) = Ctr
                        Ctr = 0
                    End If
                    .Cells(Ligne, 5) = Item
                Next Item
            End If
        Next c
    End With
End Sub

Option Explicit

Sub test1()
Dim plage As Variant
Dim i As Long
Dim TabRs As Variant
Dim j As Integer

    With Sheets("Feuil1")
        .Range(.Cells(2, 5), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, 6)).ClearContents
        .Cells(1, 5) = "Nom"
        .Cells(1, 6) = "Compteur"
        plage = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3))
        For i = LBound(plage, 1) To UBound(plage, 1)
            TabRs = Split(plage(i, 1), ";")
                For j = LBound(TabRs, 1) To UBound(TabRs, 1)
                        .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 1, 5) = Trim(TabRs(j))
                        ' Rajout
                        .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row + 1, 6) = plage(i, 2)
                Next j
        Next i
    End With
End Sub

Option Explicit

Sub test2()
Dim F1 As Worksheet
    Set F1 = Worksheets("Feuil1")

Dim plage() As Variant
    plage = F1.Range(F1.Cells(2, 2), F1.Cells(F1.Cells(F1.Rows.Count, 2).End(xlUp).Row, 3))
        F1.Cells(1, 5) = "Nom"
        F1.Cells(1, 6) = "Compteur"

Dim i As Long
Dim j As Integer
Dim TabRs() As String
    For i = LBound(plage, 1) To UBound(plage, 1)
        TabRs = Split(plage(i, 1), ";")
            F1.Cells(F1.Cells(F1.Rows.Count, 5).End(xlUp).Row + 1, 5).Resize(UBound(TabRs) + 1) = Application.Transpose(TabRs)
                For j = LBound(TabRs, 1) To UBound(TabRs, 1)
                    TabRs(j) = plage(i, 2)
                Next j
                    F1.Cells(F1.Cells(F1.Rows.Count, 6).End(xlUp).Row + 1, 6).Resize(UBound(TabRs) + 1) = Application.Transpose(TabRs)
    Erase TabRs
    Next i
Erase plage, TabRs
Set F1 = Nothing
i = Empty
j = Empty
End Sub

Option Explicit

Sub test2()
Dim plage As Range, cel As Range, Item As Variant
Dim ligne As Long, derlig As Long, nb As Long

    Application.ScreenUpdating = False
    ligne = 1

    With Sheets("Feuil1")
        derlig = .Range("f" & Rows.Count).End(xlUp).Row
        .Range("f1:g" & derlig).ClearContents
   
        Set plage = .Range("b2", .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3))
   
        For Each cel In plage
            If cel.Value <> "" And Not IsNumeric(cel.Value) Then
                nb = cel.Offset(0, 1).Value
                For Each Item In Split(cel.Value, "; ")
                    ligne = ligne + 1
                    .Cells(ligne, 6) = Item
                    .Cells(ligne, 7) = nb
                Next Item
            End If
        Next cel
   
        .Cells(1, 6) = "NOMS"
        .Cells(1, 7) = "R.D.V."
        .Range("F:G").Columns.AutoFit
    End With
End Sub