compteur recapitulatif

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim derlig As Long, nom$, tablo(1 To 16), i As Long, j As Byte, ref As Range
derlig = [A65536].End(xlUp).Row
If Target.Row < 6 Or Target.Row > derlig Then Exit Sub
Cancel = True
nom = Cells(Target.Row, 1)
'---Constitution du tableau---
tablo(1) = nom
For i = 6 To derlig
  If Cells(i, 1) = nom Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(nom, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End Sub

Private Sub CommandButton1_Click()
Dim nom$, v, tablo(1 To 16), i As Long, j As Byte, ref As Range
[COLOR="Red"]1 nom = InputBox("Entrer le nom à transférer :", "Transférer", nom)[/COLOR]
If nom = "" Then Exit Sub
v = Application.Match(nom, [A6:A65536], 0)
If IsError(v) Then MsgBox "Nom introuvable...": GoTo 1
v = v + 5
'---Constitution du tableau---
tablo(1) = nom
For i = v To [A65536].End(xlUp).Row
  If Cells(i, 1) = nom Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(nom, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

'---Création de la liste des noms sans doublons---
If Target.Column = 1 Then
Dim d, cel As Range
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Range("A6", [A65536].End(xlUp))
  If Not d.exists(cel.Value) Then d.Add cel.Value, cel.Value
Next
[Q:Q].ClearContents
[Q1].Resize(d.Count) = Application.Transpose(d.Items)
[COLOR="Red"][Q:Q].Sort Key1:=[Q1], Order1:=xlAscending, Header:=xlNo[/COLOR]
End If

If Target.Address = "$C$3" Then
Dim v, tablo(1 To 16), i As Long, j As Byte, ref As Range
v = Application.Match(Target, [A6:A65536], 0)
If IsError(v) Then Exit Sub
'---Constitution du tableau---
tablo(1) = Target
For i = v + 5 To [A65536].End(xlUp).Row
  If Cells(i, 1) = Target Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End If

End Sub