XL 2010 archiver le travail

Eric KERGRESSE à dit:

Bonjour,

VB:

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

Code:

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

Cliquez pour agrandir...

​

saddoud w à dit:

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

​

Cliquez pour agrandir...

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

patricktoulon à dit:

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

VB:

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

Cliquez pour agrandir...