XL 2010 archiver le travail

[saddoud w]

Bonjour,

J’ai un problème … je désire archiver mon travail et effacé des feuilles …. Alors pour effacer les feuilles j’ai trouvé une solution mais je veux que mon classeur soit copié avec un nouveau nom avant d’effacer les feuilles … je pose un exemple pour mieux comprendre …merci d’avance

 

[Eric KERGRESSE]

Bonjour,

Private Sub CommandButton2_Click()

Dim xWs As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With ActiveWorkbook
        .SaveCopyAs .Path & "\" & .Sheets("Feuil1").Range("A1") & " " & GroupeDateHeure & ".xlsm"
        For Each xWs In .Worksheets
            If xWs.Name <> "Feuil1" And xWs.Name <> "Feuil2" And xWs.Name <> "Feuil3" Then xWs.Delete
        Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

Dans un module standard

Function GroupeDateHeure()

Dim DateDeCreation
Dim HeureEnCours As Variant

    DateDeCreation = Year(Date) & "-" & Format(Month(Date), "00") & "-" & Format(Day(Date), "00")
    HeureEnCours = Split(Time, ":")
    GroupeDateHeure = DateDeCreation & " " & Join(HeureEnCours, "-")

End Function

 

[saddoud w]

Bonjour,

Private Sub CommandButton2_Click()

Dim xWs As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With ActiveWorkbook
        .SaveCopyAs .Path & "\" & .Sheets("Feuil1").Range("A1") & " " & GroupeDateHeure & ".xlsm"
        For Each xWs In .Worksheets
            If xWs.Name <> "Feuil1" And xWs.Name <> "Feuil2" And xWs.Name <> "Feuil3" Then xWs.Delete
        Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

Dans un module standard

Function GroupeDateHeure()

Dim DateDeCreation
Dim HeureEnCours As Variant

    DateDeCreation = Year(Date) & "-" & Format(Month(Date), "00") & "-" & Format(Day(Date), "00")
    HeureEnCours = Split(Time, ":")
    GroupeDateHeure = DateDeCreation & " " & Join(HeureEnCours, "-")

End Function

bonjour ...
malheureusement ça n'a pas marché .... rien ne se passe

​

 

[saddoud w]

bonjour ...
malheureusement ça n'a pas marché .... rien ne se passe

​

salut ça marcher après une petite modification

.SaveCopyAs "D:\Ms Archive\" & Worksheets("feuil1").Range("a1") & ".xlsm"

merci encore

 

[patricktoulon]

bonsoir
change tout le code de ta feuil1 pour celui ci
adapte le chemin

Private Sub CommandButton1_Click()
    ActiveSheet.Range("a1") = [a1] + 1
    ThisWorkbook.ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "test " & ActiveSheet.Range("a1")
    ActiveSheet.DrawingObjects.Delete
End Sub

Private Sub CommandButton2_Click()
    Dim Wsh As Worksheet, chemin
    chemin = ThisWorkbook.Path & "\archive_du_" & Format(Now, "yyyy-mm-dd-hh-mm-ss") & ".xlsm"
    ThisWorkbook.SaveCopyAs chemin
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Wsh In ThisWorkbook.Worksheets
        If Wsh.Name <> "Feuil1" And Wsh.Name <> "Feuil2" And Wsh.Name <> "Feuil3" Then
            Wsh.Delete
        End If
    Next
    Feuil1.Activate
End Sub

 

[saddoud w]

bonsoir
change tout le code de ta feuil1 pour celui ci
adapte le chemin

Private Sub CommandButton1_Click()
    ActiveSheet.Range("a1") = [a1] + 1
    ThisWorkbook.ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "test " & ActiveSheet.Range("a1")
    ActiveSheet.DrawingObjects.Delete
End Sub

Private Sub CommandButton2_Click()
    Dim Wsh As Worksheet, chemin
    chemin = ThisWorkbook.Path & "\archive_du_" & Format(Now, "yyyy-mm-dd-hh-mm-ss") & ".xlsm"
    ThisWorkbook.SaveCopyAs chemin
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Wsh In ThisWorkbook.Worksheets
        If Wsh.Name <> "Feuil1" And Wsh.Name <> "Feuil2" And Wsh.Name <> "Feuil3" Then
            Wsh.Delete
        End If
    Next
    Feuil1.Activate
End Sub

merci beaucoup c'est génial

 

[Eric KERGRESSE]

Bonjour,
Bonjour Patrick,

Pour info le fichier. La fonction que vous n'avez pu mettre en place permet d'horodater le fichier.