Sub Extraire(strName As String)
Dim sh As Worksheet
'Tester si une feuille du nom contenu dans strName existe déjà
On Error Resume Next
Set sh = ThisWorkbook.Sheets(strName)
On Error GoTo 0
'Si la feuille n'exitait pas, on la crée et la nomme
If sh Is Nothing Then
Set sh = ThisWorkbook.Sheets.Add
sh.Name = strName
Else
sh.Rows.Delete 'tout supprimer si la feuille existe déjà
End If
'Créer un zone de critères d'extraction
sh.Range("A1") = "Nom"
sh.Range("A2") = strName
'Extraire les données
With Sheets("Donnée").Range("A1").CurrentRegion
.Rows(1).Resize(, 17).Copy Destination:=sh.Range("A4")
.AdvancedFilter Action:=xlFilterCopy, criteriarange:=sh.Range("A1:A2"), copytorange:=sh.Range("A4").Resize(, 17)
End With
'Supprimer les lignes de la plage de critère + 1
sh.Rows("1:3").EntireRow.Delete
'Si l'extraction a retourné plus d'une ligne alors créer un nouveau classeur avec
If sh.Range("A1").CurrentRegion.Rows.Count > 1 Then
sh.Copy
' ActiveWorkbook.SaveAs "CheminEtNomdufichier.xls"
Else
MsgBox "Aucune donnée extraite pour '" & strName & "'", vbInformation, "Extraction"
End If
End Sub