Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, w As Worksheet, lig&, sup As Range
Set r = Intersect(Target, ListObjects(1).DataBodyRange) 'tableau Excel
If r Is Nothing Then Exit Sub
'---liste des noms des feuilles de calcul---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
d(w.Name) = ""
Next
'---transferts---
For Each r In Intersect(r.EntireRow, ListObjects(1).DataBodyRange).Rows 'si entrées multiples
If d.exists(CStr(r.Cells(4))) Then
If Application.CountA(r) = 9 Then 'si la ligne est complète
With Sheets(CStr(r.Cells(4))).ListObjects(1).DataBodyRange 'tableau Excel
lig = .Rows.Count - (.Cells(.Rows.Count, 1) <> "")
.Cells(lig, 1) = r.Cells(1)
.Cells(lig, 4).Resize(, 5) = r.Cells(5).Resize(, 5).Value
End With
Set sup = Union(IIf(sup Is Nothing, r, sup), r)
End If
End If
Next
Application.EnableEvents = False 'désactive les évènements
If Not sup Is Nothing Then sup.Delete xlUp
Application.EnableEvents = True 'réactive les évènements
End Sub