Création de fichiers Excel

Bonjour à tous,

J'ai trouvé ce code sur internet qui m'est bien utile. Il me permet de créer des fichiers Excel pour chaque feuille lorsqu'elles présentent une valeur dans la cellule "A4". Donc si la feuille 3 a une valeur dans la cellule "A4", alors le programme créer un fichier Excel avec uniquement cette feuille.

Cependant, je souhaite faire une modification, mais je n'y arrive pas. Je souhaiterais que pour chaque feuille Excel crée, qu'on retrouve systématiquement la feuille "Info" en plus de la feuille 3, par exemple.

Merci d'avance pour votre aide.

Cordialement.

Sub Séparer_les_feuilles()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim xWs As Worksheet
    Dim xWb As Workbook
    Dim xNWb As Workbook
    Dim FolderName As String
    Application.ScreenUpdating = False
    Set xWb = Application.ThisWorkbook

    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = xWb.Path & "\" & xWb.Name & " " & DateString

    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    MkDir FolderName

    For Each xWs In xWb.Worksheets
    On Error GoTo NErro
        If xWs.Range("A4") <> "" Then
        xWs.Select
        xWs.Copy
        xFile = FolderName & "\" & xWs.Name & FileExtStr
        Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
        xNWb.SaveAs xFile, FileFormat:=FileFormatNum
        xNWb.Close False, xFile
        End If
NErro:
        xWb.Activate
    Next

        MsgBox "Les feuilles sont dans ce fichier " & FolderName
        Sheets(1).Activate
        Application.ScreenUpdating = True

End Sub

Bonjour CarteSime,

Portion de code à substituer pour copier la feuille info en plus de la feuille où A4 est <> "".

    For Each xWs In xWb.Worksheets
        On Error GoTo NErro
        If xWs.Name <> "Info" And xWs.Range("A4") <> "" Then
            xWb.Worksheets(Array("Info", xWs.Name)).Copy
            Set xNWb = ActiveWorkBook
            xFile = FolderName & "\" & xWs.Name & FileExtStr
            xNWb.SaveAs xFile, FileFormat:=FileFormatNum
            xNWb.Close False, xFile
        End If
NErro:
        xWb.Activate
    Next

Cdlt,

Cylfo

C'est parfait, merci beaucoup !

Bonne journée.