Sub Extraire()
Dim plg As Range, f As Worksheet
Dim fin&, i&, a&, fin1&
'déterminer la plage à extraire dans la feuille Base
With Sheets("Archers inscrits")
Set plg = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
'Boucler sur toutes les feuilles du classeurs
For Each f In ThisWorkbook.Sheets
'Si le nom de la feuille commence par 'Club ' (espace compris)
If f.Name Like ("CLUB *") Then
'nettoyer toutes les cellules de la feuille
f.Cells.ClearContents
'préparation du critère de filtrage avancé
f.Range("A1") = "Catégorie"
'critère basé sur la fin du nom de la feuille
f.Range("A2") = "=""=" & Replace(f.Name, "CLUB ", "") & """"
'Extraction des données
plg.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=f.Range("A1:A2"), CopyToRange:=f.Range("A4:I4"), Unique:=False
'destruction des lignes de critère et séparation
f.Rows("1:3").EntireRow.Delete
'destruction des colonnes non nécessaires
f.Columns("G:I").EntireColumn.Delete
f.Columns("A:C").EntireColumn.Delete
'saisie de la formule sommeprod
f.Range("D2").Formula = "=SUMPRODUCT((Championnat!RC:R[65534]C='CLUB <8'!RC[-3])*(Championnat!RC[-1]:R[65534]C[-1]=""<8"")*(Championnat!RC[206]:R[65534]C[206]))"
'Recopie vers le bas de la formule (ne marche pas)
Selection.AutoFill Destination:=Range("D2:D" & Range("A65536").End(xlUp).Row).FillDown
With Feuil31
fin = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To fin
fin1 = Sheets("CLUB " & .Cells(i, 8)).Range("A" & Rows.Count).End(xlUp).Row
For a = 2 To fin1 - 1
If Sheets("Club " & .Cells(i, 8)).Cells(a, 1) = Sheets("CLUB " & .Cells(i, 8)).Cells(fin1, 1) Then
With Sheets("CLUB " & .Cells(i, 8))
.Range(.Cells(fin1, 1), .Cells(fin1, 3)).ClearContents: Exit For
End With
End If
Next a
Next i
End With
End If
Next
End Sub