Sauvegarder en figeant la date

bonjour a tout le forum

dans le code suivant qui sauve ma feuille sans les codes et boutons, comment puis je faire pour que la date qui est en cellule i17 sous ce format

=" en date du "&TEXTE(A1;"j mmmm aaaa")

donc que la date soit figée pour ne pas prendre la date du jour en l'ouvrant plus tard

Public Sub envoifacnue()

Dim F As Worksheet
Dim Chemin As String
Dim Client As String
Dim Sh As Shape

  Set F = ThisWorkbook.Sheets(WS_FACTURE)

  Select Case F.Range("D1")
  Case "DEVIS"
    Chemin = "D:\Facturation-v1s\factureseule\devis\"
  Case "FACTURE ACOMPTE"
    Chemin = "D:\Facturation-v1s\factureseule\facture acompte\"
  Case "FACTURE ACQUITTEE"
    Chemin = "D:\Facturation-v1s\factureseule\facture acquittée\"
  Case "FACTURE"
    Chemin = "D:\Facturation-v1s\factureseule\factures\"
  Case Else
    MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
    End
  End Select

  Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")

  Application.ScreenUpdating = False

  F.Copy
  With ActiveWorkbook
    With .Sheets(1)
      For Each Sh In .Shapes
        If Sh.Type <> msoPicture Then
          Sh.Delete
        End If
      Next Sh

      .Cells.Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    Application.DisplayAlerts = False  ' Si fichier identique présent : l'écrase sans alerte
   .SaveAs Filename:=Chemin & Client & ".xlsx"
    .Close
  End With
End Sub

merci beaucoup de votre aide j'ai essayer cette ligne sans succès

F.Cells(I17) = F.Cells(I17).Value

Pascal

Bonjour,

Une approche avec ce bout de code.

Cdlt.

Public Sub DEMO()
Dim ws As Worksheet

    Set ws = ActiveSheet

    ws.Copy

    With ActiveWorkbook.Worksheets(1)
        .UsedRange.Value = .UsedRange.Value
    End With

    Set ws = Nothing

End Sub

Bonjour Jean-Eric

merci de ta réponse mais pour I17 le code que tu as donné ne correspond pas ?

Pascal

Re,

Je crains de ne pas comprendre.

Le bout de code copie une feuille dans un nouveau classeur sans les formules.

La feuille copiée inclut la date en I17!?

Cdlt.

bonjour

en fait je me suis trompé de code

Private Sub CB_EnregistreDansLaBase_Click()
'procédure enregistrement sous PDF rectifié par BrunoM45 de excel-vba
  Dim NomFicXL As String, CheminXL As String
  Dim NomFicPDF As String, CheminPDF As String
  Dim DLig As Long
  Dim shp As Shape
  Dim Sht As Worksheet

  Set Sht = ThisWorkbook.Sheets(WS_FACTURE)

  If Sht.Range("IS_DOC_SAVED_IN_BASE") Then
    UpdateTitre Sht.Range("DOC_TYPE")
  End If
  Sht.Range("IS_DOC_SAVED_IN_BASE") = True

  DLig = Sht.Range("C" & Rows.Count).End(xlUp).Row
  Dim NomDeFichier As String
  NomDeFichier = Sht.Range("DOC_TITRE").Value & " - " & Sht.Range("DOC_CLIENT").Value
  NomFicXL = NomDeFichier & ".xlsm"
  NomFicPDF = NomDeFichier & ".pdf"
  ' Pour vérification de la valeur
  Select Case UCase(Sht.Range("DOC_TYPE").Value)
    Case DOC_DEVIS:  CheminXL = DIR_DEVIS
    Case DOC_FACT:  CheminXL = DIR_FACT
    Case DOC_FACT_AQUI: CheminXL = DIR_FACT_AQUI
    Case DOC_FACT_ACC: CheminXL = DIR_FACT_ACC
    Case Else
      MsgBox "Erreur pour trouver le chemin de " & Sht.Range("D1").Value
      Exit Sub
  End Select

  CheminPDF = CheminXL & "PDF\"
  CheminXL = CheminXL & "\"

  ' Sauvegarder le classeur actif dans le chemin et le nom determiné
  ' FileFormat:=xlExcel8,
  ActiveWorkbook.SaveAs Filename:=DIR_WORKSPACE & CheminXL & NomFicXL, _
                         Password:="", WriteResPassword:="", _
                        ReadOnlyRecommended:=False, CreateBackup:=False

  'SetButtonsVisible True
  '**********************************************************************************
   With Sht
            .Activate
   'code a tester et a supprimer si encore probleme
   With .PageSetup
            DLig = Range("suivant").Row
            'MsgBox DerLig
            .PrintArea = "C1:M" & DLig  'Sh.UsedRange.Rows.Count
                 '.PrintArea = ""
                 'la plage de cellules à imprimer pour chaque page
                 .PrintTitleRows = Sht.Range("C17:M18").Address
                 '.FitToPagesTall = 1
                 .FitToPagesWide = 1
                 .Orientation = xlPortrait
                 .PrintHeadings = False
                 ' "pied de page au centre"
                 .CenterFooter = "&16&""Arial,Gras""SIRET : 00000   -   NAF : 0000   -   RCS : 00000 -   N° TVA   :  FR00000000" & Chr(10) & _
                                                     "assurance décennale n°0000000 de chez untel"

            End With
            End With
  '**********************************************************************************

  ' Exporter en PDF
  ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DIR_WORKSPACE & CheminPDF & NomFicPDF, Quality:= _
                                                 xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                                 OpenAfterPublish:=False

  SetButtonsVisible True

  MsgBox "Votre sauvegarde porte la référence : " & " " & NomFicXL & vbCrLf _
       & "Le fichier PDF à été créé sous le nom : " & NomFicPDF

  ' Fermer le classeur actif
  'ActiveWorkbook.Close

  'Sauvegarde les modifications
  AjouteDocDansLaBase

  With ThisWorkbook.Worksheets(WS_FACTURE).Range("DOC_TYPE")
    If .Value = DOC_FACT Or .Value = DOC_FACT_AQUI Then
        ConsommeLesArticlesDansLaBaseArticles
    End If
  End With

  If Sht.Range("DOC_TYPE") = DOC_FACT_ACC Then
    Dim Client As InfoClient: GetClientInfos Client
    Dim montant As Double
    Dim paiement As InfoPaiement
    GetHiddenPaiementInfoToWs ThisWorkbook.Worksheets(WS_FACTURE), paiement, montant
    AjoutePaiementDansLaBase ThisWorkbook, Client, paiement, montant
    AjouteFacturePayeDansLaBase DOC_FACT_ACC, ThisWorkbook
  End If

  If ThisWorkbook.Worksheets(WS_FACTURE).Range("Totaltva10") > 0.0001 And _
    ThisWorkbook.Worksheets(WS_FACTURE).Range("DOC_TYPE") <> DOC_DEVIS Then
      DoAttestation7Percent
  End If
  Me.Hide

End Sub

c'est le code d'enregistrement du devis où facture qui ne fige pas la date

mes excuses Jean Eric

Pascal

Re,

Je ne comprends toujours.

Cdlt.

Bonjour

d'après ce qu j'ai compris

et aux codes que j'ai trouvé dans ce meme forum

essaie ceci sans aucune prétention

dans un module standard

Global gIsModified As Boolean

Function GetDateModif() As Date

GetDateModif = ActiveWorkbook.BuiltinDocumentProperties("Last save time")

End Function

Sub auto_close()

If gIsModified Then

Range("Feuil1!I17") = GetDateModif()

End If

End Sub

Sub auto_open()

gIsModified = False

End Sub

et dans l'ouverture de ton form

Feuil1.Range("I17")=now

bonsoir Bakh, Jean Eric et le forum

j'ai essayer ceci sur un devis mais je ne saurais que demain si cela fonctionne

 Sht.Range("I17") = Sht.Range("I17").Value

je l'ai mise entre ces 2 lignes

Set Sht = ThisWorkbook.Sheets(WS_FACTURE)

  If Sht.Range("IS_DOC_SAVED_IN_BASE") Then

je n'ai pas eu de bug donc avec espoir, c'est a la dernière ligne du code que bakh a donné que je me suis rendu compte qu'il me manquais les crochets encadrant I17 et c'est peut être la source de mon post

Pascal

bonjour Jean-Eric, Bakh

Bakh merci de m'avoir montré où je faisais l'erreur

Jean-Eric Merci aussi de m'avoir aidé sans y comprendre trop

merci et bon dimanche

Pascal