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")
    ' Transformation de votre code
    ' commentaire ci-dessous
    '.Range(.[B2], .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3)).Select
        ' Vous
        ' Set Plage = .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
        ' Moi
        Set Plage = .Range(.[B2], .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3))
        For Each c In Plage
            ' MsgBox c.Address
            ' Ici j'ai pas compris l'utilité
            ' Ctr = c.Offset(, -1).Value
            ' MsgBox Ctr
            ' Pour moi je test dans la plage de 3 lignes et 2 colonnes
            ' comme For each balais la plage comme suit
            ' Toutes les ligne de la premiére colonne
            ' Puis toutes les lignes de la deuxiéme colonne
            ' alors lorsque c aura l'adress de la deuxiéme colonne
            ' et que se sont que des valeurs numéric je saute
            ' cette instruction avec ceci : Not IsNumeric(c.Value)
            ' se ne sont pas des valeurs numérique
            If c.Value <> "" And Not IsNumeric(c.Value) Then
                For Each Item In Split(c.Value, "; ")
                    Ligne = Ligne + 1
                    ' Ici j'ai pas compris aussi l'utilité en dessous en commentaire
                    'If Ctr <> 0 Then
                        '.Cells(Ligne, 2) = Ctr
                        'Ctr = 0
                    'End If
                    .Cells(Ligne, 5) = Item                 ' Nom et Prénom
                    ' Ici comme je ne traite pas les valeurs numéric
                    ' j'utilise offset pour récupérer la valeur de la deuxiéme colonne
                    ' avec ceci : c.Offset(0, 1).Value
                    ' C'est pour cela que j'ai pas compris le Ctr = c.Offset(, -1).Value du début
                    .Cells(Ligne, 6) = c.Offset(0, 1).Value ' Numéro consultation
                Next Item
            End If
        Next c
    End With
End Sub

Private Sub CommandButton1_Click()
Recap_ID
End Sub

Option Explicit
Option Base 1
Public Ws_Cible As Worksheet
Public Coll_ID As Collection
Public Nbr_RDv As Integer

Public Tab_Gen As Variant
Public Tab_Recup As Variant
Public Tab_Recap() As Variant
Public Tab_BY_ID() As Variant

Public DerLgn As Long
Public Lgn As Long
Public DerCol As Byte

Public Str_ID As String
Public x As Long
Public xx As Long
Public i As Integer
Public ii As Integer
Public iii As Integer

Public Sub Recap_ID()
Application.ScreenUpdating = False
Set Ws_Cible = Worksheets("Feuil1") 'on initialise la variable
Set Coll_ID = New Collection 'Initialise la Collection des Noms
x = 1: xx = 1 'on initialise les variables
  With Ws_Cible 'avec la feuille ainsi definie
     DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row 'on détermmine la derniere ligne non vide de la Colonne A(1) de la feuille Cible
     DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'on dtermine la Derniere colonne non vide de la premiere ligne
    Tab_Gen = .Range(.Cells(2, 1), .Cells(DerLgn, DerCol)).Value 'on récupére les données de la palge ainsi définie dans un tableau
   For Lgn = 1 To UBound(Tab_Gen, 1) 'pour chaque lignes du tableau

        Nbr_RDv = Tab_Gen(Lgn, 2) 'on récupére le nombre de points
    If InStr(1, Tab_Gen(Lgn, 1), ";") <> 0 Then 'si plusieurs ID
        Tab_Recup = Split(Tab_Gen(Lgn, 1), ";") 'on les récuépre dans un tableau temporaire
      Else
        Tab_Recup(1) = Tab_Gen(Lgn, 1) 'si un seul nom on le récupére
    End If
      For i = 0 To UBound(Tab_Recup) 'pour chaque colonnes du tableau temporaire
      ReDim Preserve Tab_Recap(2, x) 'on redimansionne le tableau 2 lignes x colonnes
      Tab_Recap(1, x) = Trim(Tab_Recup(i)) 'on récupére le Contact
      Tab_Recap(2, x) = Nbr_RDv 'on récuépre les Points
      x = x + 1 'on incremente les colonnes du tableau temporaire
      Next i
   Next Lgn
'pour test
    .Cells(1, 4) = "Contacts": .Cells(1, 5) = "rdv" 'on colle les entetes
    .Range("D2").Resize(UBound(Tab_Recap, 2), 2) = Application.Transpose(Tab_Recap) 'ici on récupére la Liste des Rdv
'on va réunir les Rdv par Contact
   On Error Resume Next 'gestion des erreurs
  For ii = 1 To UBound(Tab_Recap, 2) 'pour chaque colonnees du tableau temporaire
  Str_ID = UCase(Tab_Recap(1, ii)) 'on récupére le Contact
'**************
    Coll_ID.Add Str_ID, CStr(Str_ID) 'on l'entre dans la collection des Contacts Unique
'**************
      If Err.Number = 0 Then 'si contact pas encore dans la Collection
          ReDim Preserve Tab_BY_ID(2, xx) 'on redimmansionne le tableau 2 lignes Toujours
            Tab_BY_ID(1, xx) = Str_ID 'on colle le Contact sur la première ligne    
                For iii = 1 To UBound(Tab_Recap, 2) 'on va lister toutes les lignes pour vérifier si contact présent plusieurs fois
                  If UCase(Tab_Recap(1, iii)) = Str_ID Then 'si present
                    Tab_BY_ID(2, xx) = Tab_BY_ID(2, xx) + Tab_Recap(2, iii) 'on cumule les RDVs
                  End If
                Next iii 'autre colonne      
          xx = xx + 1 'on incremente le Nombre de colonnes du tableau
      End If
      Err.Clear
  Next ii
   .Cells(1, 7) = "CONTACTS": .Cells(1, 8) = "RDV" 'on colle les entetes
   .Range("G2").Resize(UBound(Tab_BY_ID, 2), 2) = Application.Transpose(Tab_BY_ID) 'on colle le tableau en l'inversant
  End With
  Application.ScreenUpdating = True
Erase Tab_Gen: Erase Tab_Recup: Erase Tab_Recup: Erase Tab_BY_ID 'on vide les tableaux
End Sub

Sub abcd()
Dim t, tt, i&, j&
t = Range("B2", Cells(Rows.Count, "C").End(3)).Value: j = 2
For i = LBound(t) To UBound(t)
tt = Split(t(i, 1), ";")
    With Cells(j, "E").Resize(UBound(tt) + 1)
    .Value = Application.Transpose(tt): .Offset(, 1) = t(i, 2)
    End With
j = Cells(Rows.Count, "E").End(3).Row + 1
Next
End Sub

Option Explicit
Option Base 1
Public Ws_Cible As Worksheet
Public Coll_ID As Collection
Public Nbr_RDv As Integer

Public Tab_Gen As Variant
Public Tab_Recup As Variant
Public Tab_Recap() As Variant
Public Tab_BY_ID() As Variant

Public DerLgn As Long
Public Lgn As Long
Public DerCol As Byte

Public Str_ID As String
Public x As Long
Public xx As Long
Public i As Integer
Public ii As Integer
Public iii As Integer

Public Sub Recap_ID()
Application.ScreenUpdating = False
 Set Ws_Cible = Worksheets("Feuil1") 'on initialise la variable
 Set Coll_ID = New Collection 'Initialise la Collection des Noms
 x = 1: xx = 1 'on initialise les variables
  With Ws_Cible 'avec la feuille ainsi definie
     DerLgn = .Cells(.Rows.Count, 2).End(xlUp).Row 'on détermmine la derniere ligne non vide de la Colonne A(1) de la feuille Cible
     DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'on dtermine la Derniere colonne non vide de la premiere ligne
    Tab_Gen = .Range(.Cells(2, 2), .Cells(DerLgn, DerCol)).Value 'on récupére les données de la palge ainsi définie dans un tableau
   For Lgn = 1 To UBound(Tab_Gen, 1) 'pour chaque lignes du tableau   
        Nbr_RDv = Tab_Gen(Lgn, 2) 'on récupére le nombre de points
    If InStr(1, Tab_Gen(Lgn, 1), ";") <> 0 Then 'si plusieurs ID
        Tab_Recup = Split(Tab_Gen(Lgn, 1), ";") 'on les récuépre dans un tableau temporaire
      Else
        Tab_Recup(1) = Tab_Gen(Lgn, 1) 'si un seul nom on le récupére
    End If
      For i = 0 To UBound(Tab_Recup) 'pour chaque colonnes du tableau temporaire
      ReDim Preserve Tab_Recap(2, x) 'on redimansionne le tableau 2 lignes x colonnes
      Tab_Recap(1, x) = Trim(Tab_Recup(i)) 'on récupére le Contact
      Tab_Recap(2, x) = Nbr_RDv 'on récuépre les Points
      x = x + 1 'on incremente les colonnes du tableau temporaire
      Next i
   Next Lgn
'pour test
    .Cells(1, 5) = "Contacts": .Cells(1, 6) = "rdv" 'on colle les entetes
    .Range("E2").Resize(UBound(Tab_Recap, 2), 2) = Application.Transpose(Tab_Recap) 'ici on récupére la Liste des Rdv
'on va réunir les Rdv par Contact
   On Error Resume Next 'gestion des erreurs
  For ii = 1 To UBound(Tab_Recap, 2) 'pour chaque colonnees du tableau temporaire
  Str_ID = UCase(Tab_Recap(1, ii)) 'on récupére le Contact
'**************
    Coll_ID.Add Str_ID, CStr(Str_ID) 'on l'entre dans la collection des Contacts Unique
'**************
      If Err.Number = 0 Then 'si contact pas encore dans la Collection
          ReDim Preserve Tab_BY_ID(2, xx) 'on redimmansionne le tableau 2 lignes Toujours
            Tab_BY_ID(1, xx) = Str_ID 'on colle le Contact sur la premiere ligne       
                For iii = 1 To UBound(Tab_Recap, 2) 'on va lister toutes les lignes pour verifier si contact présent plusieur fois
                  If UCase(Tab_Recap(1, iii)) = Str_ID Then 'si present
                    Tab_BY_ID(2, xx) = Tab_BY_ID(2, xx) + Tab_Recap(2, iii) 'on cumule les RDVs
                  End If
                Next iii 'autre colonne         
          xx = xx + 1 'on incremente le Nombre de colonnes du tableau
      End If
      Err.Clear
  Next ii
   .Cells(1, 8) = "CONTACTS": .Cells(1, 9) = "RDV" 'on colle les entetes
   .Range("H2").Resize(UBound(Tab_BY_ID, 2), 2) = Application.Transpose(Tab_BY_ID) 'on colle le tableau en l'inversant
  End With
  Application.ScreenUpdating = True
Erase Tab_Gen: Erase Tab_Recup: Erase Tab_Recup: Erase Tab_BY_ID 'on vide les tableaux
End Sub