Sub Extract()
Dim t$, col As Range, P As Range, ncol%, chemin$, nom$, nomfeuil$, ext$
Do
t = InputBox("Lettres des colonnes séparées par un espace :", _
"Choix des colonnes")
If t = "" Then Exit Sub
t = Replace(Application.Trim(t), " ", "1,") & 1
On Error Resume Next
Set col = Evaluate(t)
On Error GoTo 0
Loop While col Is Nothing
Set col = col.EntireColumn
Set P = Feuil1.[B25].CurrentRegion.EntireRow
Application.ScreenUpdating = False
With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'nouveau document
P.Copy .[A1] '1ère copie pour la hauteur des lignes
.Cells.Clear 'RAZ
Intersect(P, col).Copy .[A1] '2ème copie, la bonne
For Each col In col 'copie la largeur des colonnes
ncol = ncol + 1
.Columns(ncol).ColumnWidth = col.ColumnWidth
Next
ChDir ThisWorkbook.Path 'répertoire courant
Application.Dialogs(xlDialogSaveAs).Show 'enregistrement choisi
chemin = .Parent.Path
If chemin = "" Then Exit Sub 'abandon
nom = .Parent.Name
nomfeuil = Left(nom, InStrRev(nom, ".") - 1)
ext = Mid(nom, InStrRev(nom, "."))
.Name = nomfeuil 'renomme la feuille
.Parent.Close True
End With
Name chemin & "\" & nom As chemin & "\" & nomfeuil & _
Format(Now, "_yyyymmdd_hhmmss") & ext 'renomme le fichier
Application.ScreenUpdating = True
MsgBox "Opération effectuée", , "Extraction"
End Sub