Enregistrement nouveau fiichier " .SaveAs "change couleurs utilisées

Bonjour,

Je crée un nouveau fichier à partir d'un onglet de mon fichier actif.

Emplacement = "C:\Users\" & Environ("USERNAME") & "\Documents\"

DATE_JOUR = Format(Now, "d mmmm yyyy")
HEURE = Format(Now, "hh")
MINUTES = Format(Now, "nn")

    Worksheets("EXTRACT").Copy
    'there is now a new active workbook
    With ActiveWorkbook
        'save it
        .SaveAs Filename:=Emplacement & "EXTRACT " & DATE_JOUR & "-" & HEURE & "h" & MINUTES & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        'optionally close it
        .Close SaveChanges:=False
    End With

Le problème est que toutes les couleurs utilisées sont changées sur le nouveau fichier.
(Couleur des cellules et des formes)

Comment peut on s'y prendre pour que les couleurs restent inchangées?

Je vous remercie par avance.

Olivier

Hello,

C'est lié aux modifications de thème

Sub ExportAvecCouleurs()

    Set wbSource = ThisWorkbook

    Emplacement = "C:\Users\" & Environ("USERNAME") & "\Documents\"
    DATE_JOUR = Format(Now, "d mmmm yyyy")
    HEURE = Format(Now, "hh")
    MINUTES = Format(Now, "nn")

    ' Copier la feuille dans un nouveau classeur
    wbSource.Worksheets("EXTRACT").Copy
    Set wbNouveau = ActiveWorkbook

    ' Appliquer le même thème que le classeur source
    wbNouveau.Theme.ThemeColorScheme.Load wbSource.Theme.ThemeColorScheme.Name

    ' Enregistrer et fermer
    wbNouveau.SaveAs Filename:=Emplacement & "EXTRACT " & DATE_JOUR & "-" & HEURE & "h" & MINUTES & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    wbNouveau.Close SaveChanges:=False
End Sub

Essaie ça

@+

Intéressant :-)

Je rencontre une erreur à ce niveau :

Bonjour,

C'est parce que la copie des thèmes n'est malheureusement pas très automatisable via VBA. Une solution de contournement :

Dans le classeur de base, celui avec le bon thème, tu exportes son thème, par exemple dans son dossier. C'est la manip ci-dessous.

Ensuite, en VBA tu auras simplement l'instruction suivante à mettre en place :

' Appliquer le même thème que le classeur source
wbNouveau.ApplyTheme wbSource.Path & "\Theme1.thmx" ' avec Theme1 le nom du thème que tu as exporté bien entendu

Hello,

J'ai tenté mais ça ne fonctionne pas en effet

Autre méthode ça serait de dupliquer le fichier en supprimant toutes les autres feuilles

Sub ExportFeuilleAvecCouleurs()

    Set wbSource = ThisWorkbook

    Emplacement = "C:\Users\" & Environ("USERNAME") & "\Documents\"
    cheminTemp = Emplacement & "TempCopie.xlsx"
    DATE_JOUR = Format(Now, "d mmmm yyyy")
    HEURE = Format(Now, "hh")
    MINUTES = Format(Now, "nn")

    ' Dupliquer le fichier
    wbSource.SaveCopyAs cheminTemp
    Set wbNouveau = Workbooks.Open(cheminTemp)

    ' Supprimer tout sauf "EXTRACT"
    Application.DisplayAlerts = False
    For Each ws In wbNouveau.Worksheets
        If ws.Name <> "EXTRACT" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

    ' Enregistrer sous le nom final
    wbNouveau.SaveAs Filename:=Emplacement & "EXTRACT " & DATE_JOUR & "-" & HEURE & "h" & MINUTES & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    wbNouveau.Close SaveChanges:=False

    ' Supprimer le fichier temporaire
    Kill cheminTemp
End Sub

@+

Je vous remercie pour vos solutions.

Je suis bloqué dans une réunion, je me penche dessus et teste tout ça dès que je suis libre.