Private Sub Worksheet_Activate()
Dim d As Object, c As Range, j%, partie%, i&, s
Application.ScreenUpdating = False
'---repérage et effacement des tableaux---
Set d = CreateObject("Scripting.Dictionary")
For Each c In UsedRange
If c = "Nom" Then
d(c(5, 2).Value) = c.Address 'mémorise l'adresse de la 1ère cellule
Union(c(1, 2).Resize(3), c(8, 2).Resize(4, 3)) = ""
End If
Next c
'---remplissage des tableaux---
With Sheets("Parties")
For j = 2 To 23 Step 7
partie = partie + 1
For i = 4 To .Cells(.Rows.Count, j).End(xlUp).Row
If d.exists(.Cells(i, j).Value) Then 'joueur de gauche
Set c = Range(d(.Cells(i, j).Value))
s = Split(.Cells(i, j + 1))
c(1, 2) = s(0) 'nom
c(2, 2) = s(1) 'prénom
c(3, 2) = Application.VLookup(c(5, 2), Sheets("Classement").Columns("C:E"), 3, 0) 'ville
c(7 + partie, 2) = .Cells(i, j + 3)
c(7 + partie, 3) = .Cells(i, j + 2)
c(7 + partie, 4) = .Cells(i, j + 5)
End If
If d.exists(.Cells(i, j + 3).Value) Then 'joueur de droite
Set c = Range(d(.Cells(i, j + 3).Value))
s = Split(.Cells(i, j + 4))
c(1, 2) = s(0) 'nom
c(2, 2) = s(1) 'prénom
c(3, 2) = Application.VLookup(c(5, 2), Sheets("Classement").Columns("C:E"), 3, 0) 'ville
c(7 + partie, 2) = .Cells(i, j)
c(7 + partie, 3) = .Cells(i, j + 5)
c(7 + partie, 4) = .Cells(i, j + 2)
End If
Next i, j
End With
End Sub