Option Explicit
Sub Résumer()
Dim ChNomF, Wbk As Workbook, LOt As ListObject, ColRDV As Integer, ColDate As Integer, _
ColComm As Integer, ColCatg As Integer, ColClie As Integer, TRésu(1 To 500, 1 To 4), _
SGrDate As SsGr, SGrComm As SsGr, L As Integer, Score As Single, SGrCatg As SsGr, _
Points As Single, Wsh As Worksheet
ChNomF = Application.GetOpenFilename("Fichier Excel, *.xls*")
If VarType(ChNomF) <> vbString Then Exit Sub
Set Wbk = Workbooks.Open(ChNomF)
Set LOt = Wbk.Worksheets(1).ListObjects(1)
ColRDV = LOt.ListColumns("RDV").Index
ColDate = LOt.ListColumns("DATE RDV").Index
ColComm = LOt.ListColumns("COMMERCIAL").Index
ColCatg = LOt.ListColumns("CATEGORIE").Index
ColClie = LOt.ListColumns("N° Client").Index
For Each SGrDate In Gigogne(LOt, ColRDV, ColDate, ColComm, ColCatg, ColClie).Item("Externe").Co
For Each SGrComm In SGrDate.Co
L = L + 1: TRésu(L, 1) = L: TRésu(L, 2) = SGrDate.Id: TRésu(L, 3) = SGrComm.Id
Score = 0
For Each SGrCatg In SGrComm.Co
Points = SGrCatg.Count: If SGrCatg.Id <> "Mecano" Then Points = Points / 2
Score = Score + Points
Next SGrCatg
If Score > 3 Then Score = 3
If Score > 0.5 Then TRésu(L, 4) = "MT" & Int(Score)
Next SGrComm, SGrDate
On Error Resume Next
Set Wsh = Wbk.Worksheets("Résultat")
On Error GoTo 0
If Wsh Is Nothing Then
Set Wsh = Wbk.Worksheets.Add: Wsh.Name = "Résultat"
Wsh.[B2:E2].Value = Array("ID", "DATE RDV", "COMMERCIAL", "RESULTAT")
End If
Wsh.[B3].Resize(500, 4).Value = TRésu
End Sub