Public ListeFeuilles, Factive
Sub ConstruireFichier()
Dim L%
Set Factive = ActiveSheet
Application.StatusBar = "Suppression des feuilles.": SupprimerFeuilles
Application.StatusBar = "Faire la Liste des Feuilles.": FaireListeFeuilles
Application.ScreenUpdating = False
For L = 1 To UBound(ListeFeuilles)
If ListeFeuilles(L, 1) = "" Then Exit For
CreerRemplirFeuilles (L)
Next L
Application.StatusBar = ""
End Sub
Sub CreerRemplirFeuilles(L)
'Créer une feuille, la renomme, la remplit
On Error GoTo FinCréer
Dim Nom$, Début%, Fin%, Taille%
Nom = ListeFeuilles(L, 1)
Début = ListeFeuilles(L, 2)
Fin = ListeFeuilles(L + 1, 2)
Taille = Fin - Début
Application.StatusBar = "Création de la feuille " & Nom
Sheets.Add After:=Sheets(Sheets.Count): ActiveSheet.Name = Nom
With Sheets(Nom)
Range(.Cells(1, "A"), .Cells(Taille, "J")) = Range(Factive.Cells(Début, "A"), Factive.Cells(Fin, "J")).Value
.Columns.AutoFit
End With
Factive.Select
FinCréer:
End Sub
Sub SupprimerFeuilles()
'Supprime toutes les feuilles sauf celle active.
Dim F
Application.DisplayAlerts = False
For Each F In Worksheets
If F.Name <> Factive.Name Then Sheets(F.Name).Delete
Next F
Application.DisplayAlerts = True
End Sub
Sub FaireListeFeuilles()
Dim Ligne%, L%
'Fait la liste de tous les noms de feuilles à créer
ReDim ListeFeuilles(1 To 1000, 1 To 2)
Ligne = 1
With ActiveSheet
For L = 1 To .[A60000].End(xlUp).Row
If Cells(L, "A").Font.Italic = True And Cells(L, "A").Font.Bold = True Then ' Si cellule gras/italique
Nom = ConstruireNom(.Cells(L, "A"))
If Nom <> "" Then
ListeFeuilles(Ligne, 1) = Nom ' Nom de la feuille à créer
ListeFeuilles(Ligne, 2) = L ' Numéro de la 1ere ligne à sauvegarder
Ligne = Ligne + 1
End If
End If
Next L
ListeFeuilles(Ligne, 2) = L ' Dernière ligne à sauvegarder pour la dernière feuilles
End With
End Sub
Function ConstruireNom(Nom)
Dim T, Fin%
ConstruireNom = ""
T = Split(Nom, "/"): Fin = UBound(T)
If T(Fin) <> "" Then
If Fin = 1 Then
ConstruireNom = T(Fin - 1) & "-" & Split(T(Fin), ":")(1)
Else
ConstruireNom = T(Fin - 2) & "-" & T(Fin - 1) & "-" & Split(T(Fin), ":")(1)
End If
ConstruireNom = Replace(ConstruireNom, " ", " ")
ConstruireNom = Trim(ConstruireNom)
If Len(ConstruireNom) > 31 Then ConstruireNom = Mid(ConstruireNom, 1, 31)
End If
End Function