Voici mon code entier job75,
Sub extraire() 'Extraire selon critère
Application.DisplayAlerts = False
If ActiveCell.Row > 1 And ActiveCell <> "" Then
nomOnglet = CStr(ActiveCell)
titreCritere = Cells(1, ActiveCell.Column)
Critere = ActiveCell
On Error Resume Next
Sheets(nomOnglet).Delete
On Error GoTo 0
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = nomOnglet
[P1] = titreCritere
[P2] = Critere
Sheets("Les payements").[A1:K1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[P1
2], CopyToRange:=Sheets(nomOnglet).[a1]
End If
'Mise en forme colonnes
Rows("1:1").RowHeight = 54
Columns("A:A").ColumnWidth = 18.56 'Société
Columns("B:B").ColumnWidth = 16.33 'Situation des payements
Columns("C:C").ColumnWidth = 7.89 'Somme
Columns("D
").ColumnWidth = 8.78 'Montant en attente
Columns("E:E").ColumnWidth = 9.44 'Montant remboursé
Columns("F:F").ColumnWidth = 8.78 'Montant payé
Columns("G:G").ColumnWidth = 9.44 'Facture supprimée
Columns("H:H").ColumnWidth = 9.44 'Non Indémnisé
Columns("I:I").ColumnWidth = 25.78 'Date prévue du payement
Columns("J:J").ColumnWidth = 14.11 'Code
Columns("K:K").ColumnWidth = 12.67 'Facture N°
'Columns("L:L").ColumnWidth = 2.78 'NB Réf
'Masque colonne
'Columns("C:C").Select
'Selection.EntireColumn.Hidden = True
'ActiveWindow.DisplayGridlines = False
'Columns("M:M").Select
'Selection.EntireColumn.Hidden = True
'ActiveWindow.DisplayGridlines = False
Columns("P
").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.DisplayGridlines = False
Call Tri(F)
Range("A1").Select
End Sub
Sub Tri(F As Worksheet)
Dim F As Worksheet
'----
Set F = ThisWorkbook.ActiveSheet 'ou
'Set F = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'ou
'Set F = ThisWorkbook.Sheets(nom) 'si la variable nom a été définie.
With F.ListObjects(1).Range
.Parent.Protect UserInterfaceOnly:=True
.Sort .Columns(9), xlAscending, header:=xlYes
End With
End Sub