Private Sub CommandButton1_Click()
Dim ext$, fichier$, cowc As Boolean, c As Range, deb As Range, n%, wb As Workbook, i&, nom$
ext = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")) 'extension
fichier = ThisWorkbook.Path & "\MonBeauFichier" & ext 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
cowc = Application.CopyObjectsWithCells 'mémorisation
Application.CopyObjectsWithCells = True 'pour copier les objets copiables
On Error Resume Next
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
If LCase(Trim(c)) Like "d?part" Then 'Départ ou DEPART
Set deb = c
ElseIf Not deb Is Nothing And LCase(Trim(c)) Like "arriv?e" Then
n = n + 1
'---création du fichier et suppression des feuilles---
If n = 1 Then
ThisWorkbook.SaveCopyAs fichier 'sauvegarde
Set wb = Workbooks.Open(fichier) 'ouverture de la sauvegarde
For i = Sheets.Count To 1 Step -1
If i <> Me.Index Then wb.Sheets(i).Delete
Next
End If
'---création des feuilles---
i = c.Row - deb.Row
nom = deb(1, 2) & IIf(i > 1, " " & deb(2, 2), "") & IIf(i > 2, " " & deb(3, 2), "")
nom = Left(Application.Trim(nom), 31) 'SUPPRESPACE et limitation à 31 caractères
With wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
.Name = nom
wb.Sheets(1).Rows(1).Copy .[A1]
Range(deb, c).EntireRow.Copy .[A2]
.Columns.AutoFit 'ajustement largeur
End With
Set deb = Nothing
End If
Next
If wb Is Nothing Then Kill fichier 'amusant
wb.Sheets(1).Delete
wb.Sheets(1).Activate
wb.Close True 'enregistrement et fermeture
Application.CopyObjectsWithCells = cowc
End Sub