trier et éffacer cellule

Sub Enregistrer()
Dim chemin$, c As Range, fichier$
chemin = ThisWorkbook.Path & "\"
Set c = Sheets("export").Range("A" & Rows.Count).End(xlUp)
fichier = Format(Date, "dd-mm-yyyy ") & c & " " & c(, 2) '???
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier a déjà été créé
On Error Resume Next
Workbooks(fichier).Close 'si le fichier est ouvert on le ferme
On Error GoTo 0
Sheets("armoire").Copy 'nouveau document
ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value 'facultatif, supprime les formules
ActiveWorkbook.SaveAs chemin & fichier
ThisWorkbook.Sheets("base").Range("A" & Rows.Count).End(xlUp)(2) = ActiveWorkbook.Name
ActiveWorkbook.Close
End Sub

Sub Enregistrer()
Dim chemin$, c As Range, fichier$
chemin = ThisWorkbook.Path & "\"
Set c = Sheets("export").Range("A" & Rows.Count).End(xlUp)
fichier = Format(Date, "dd-mm-yyyy ") & c & " " & c(, 2) '???
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier a déjà été créé
On Error Resume Next
Workbooks(fichier).Close 'si le fichier est ouvert on le ferme
On Error GoTo 0
Sheets("armoire").Copy 'nouveau document
ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value 'facultatif, supprime les formules
ThisWorkbook.Sheets("export").Copy After:=ActiveWorkbook.Sheets(1) '2ème feuille
ActiveWorkbook.Sheets(1).Activate
ActiveWorkbook.SaveAs chemin & fichier
ThisWorkbook.Sheets("base").Range("A" & Rows.Count).End(xlUp)(2) = ActiveWorkbook.Name
ActiveWorkbook.Close
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column > 1 Or Target = "" Then Exit Sub
Dim wb As Workbook
Cancel = True
On Error Resume Next
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & Target)
If wb Is Nothing Then MsgBox Target & " introuvable.."
End Sub

Private Sub TextBox1_Change()
Dim x$, t, d As Object, i&
x = "*" & LCase(TextBox1) & "*"
t = Sheets("base").[A1].CurrentRegion.Resize(, 2) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If LCase(t(i, 1)) Like x Then d(LCase(t(i, 1))) = "" 'élimine les doublons
Next
If d.Count Then ListBox1.List = d.keys Else ListBox1.Clear
TextBox1.SetFocus: TextBox1.SelStart = Len(TextBox1)
End Sub

Private Sub ListBox1_Click()
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & ListBox1)
If wb Is Nothing Then MsgBox "'" & ListBox1 & "' introuvable..."
End Sub