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
