Forum - VBA Αποθήκευση με ημερομηνία

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Αποθήκευση με ημερομηνία (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2744-apothikeysi-me-imerominia.html)

Αποθήκευση με ημερομηνία

Παιδια καλησπερα και παλι

Εχω αυτον τον κωδικα. Θελω ομως να κανω το εξης.Να αποθηκευεται πρωτα η ημερομηνια και μετα το ονομα του βιβλιου και καθε φορα που γινεται αποθηκευση να σβηνεται η παλια ημερομηνια

Κώδικας:

Sub SaveFileWithDate()

   Dim strWBOnly As String         'workbook path and name without ".xls"

    Dim strSaveWithDate As String

    Dim strWBFullName As String

  

    strWBFullName = ActiveWorkbook.FullName

    strWBOnly = Left(strWBFullName, Len(strWBFullName) - 4)

  

    strSaveWithDate = strWBOnly & "." & Format(Now(), "dd-mm-yyyy") & ".xls"

  

    ActiveWorkbook.SaveAs Filename:=strSaveWithDate, FileFormat:= _

        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

        , CreateBackup:=False

End Sub

τι πρεπει να αλλαξω ρε παιδια??

Σωτήρη καλησπέρα!

Ο παρακάτω παραδειγματικός κώδικας νομίζω ότι σε εξυπηρετεί:

Κώδικας:

Sub test()

    Dim xlFolder As String, wbName As String, ExtName As String, NewName As String

    xlFolder = ThisWorkbook.Path & "\" 'Προσάρμοσε τη διαδρομή του φακέλου

    With CreateObject("Scripting.FileSystemObject")

        wbName = .GetBaseName(ThisWorkbook.FullName)

        ExtName = "." & .GetExtensionName(ThisWorkbook.FullName)

    End With

    NewName = xlFolder & _

              Replace(Format(Now(), "dd_mm_yyyy_hh:mm:ss"), ":", "_") & "_" & wbName & ExtName

    ThisWorkbook.SaveAs NewName, ThisWorkbook.FileFormat ' ή xlnormal

End Sub

Εξήγησε μας πως προσδιορίζεται το αρχείο προς διαγραφή με την παλιά ημερομηνία για να σε βοηθήσουμε.

Τάσος

Τασο καλησπερα

Καθε φορα που παταω αποθηκευση (φτιαγμενο κουμπι με vba) τοτε συνεχεια μου βαζει μπροστα το νουμερο της ημερομηνιας.

ενω οταν κανω αποθηκευση ως pdf με τον παρακατω κωδικα τοτε το αποθηκευει μια χαρα

εγω θελω καθε φορα να αποθηκευει εκ νεου ενα αρχειο με νεα αποθηκευση.
οχι να σβηνει το παλιο
πχ αν 7 μερες το ανοιξεις 7 φορες τοτε να εχει 7 διαφ αποθηκευσεις

Κώδικας:

Public Sub SaveWorksheetsAsPDF()
 
 

On Error Resume Next
 

Dim i As Integer

Dim sName As String

Dim sOutputPath As String

 Dim strWBOnly As String         'workbook path and name without ".xls"

    Dim strSaveWithDate As String

    Dim strWBFullName As String
 
 
 

For i = 1 To ActiveWorkbook.ActiveSheet.Count
 

strWBFullName = ActiveWorkbook.FullName

strWBOnly = Left(strWBFullName, Len(strWBFullName) - 4)

sName = strWBOnly & "." & Format(Now(), "dd-mm-yyyy")
 
 

Debug.Print ActiveSheet(sName).Index & " " & sOutputPath & sName
 

ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

sOutputPath & sName, Quality:=xlQualityMinimum _

, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
 

Next
 

End Sub

Σωτήρη,
κατάλαβα ότι θέλεις κάθε φορά που πατάς το κουμπί να γίνεται αντικατάσταση του αρχείου με το ίδιο όνομα (αν υπάρχει) στο σκληρό δίσκο.

Δεν κατάλαβα όμως: Θέλεις να αποθηκεύσεις όλα τα φύλλα εργασίας του βιβλίου σε *.pdf
ή θέλεις να αποθηκεύεις το βιβλίο σε μορφή Excel;

Για να αποθηκεύεις το βιβλίο σε μορφή Excel χρησιμοποίησε το παρακάτω:

Κώδικας:

Sub testXL()

    Dim xlFolder As String, wbName As String, ExtName As String, NewName As String

    xlFolder = ThisWorkbook.Path & "\"

    With CreateObject("Scripting.FileSystemObject")

        wbName = .GetBaseName(ThisWorkbook.FullName)

        ExtName = "." & .GetExtensionName(ThisWorkbook.FullName)

        NewName = xlFolder & Format(Date, "dd_mm_yyyy") & "_" & wbName & ExtName

        On Error Resume Next

        If .FileExists(NewName) Then

            .DeleteFile NewName

        End If

    End With

    If Err <> 0 Then

        MsgBox "Σφάλμα: " & Err & vbLf & Err.Description

        Exit Sub

    Else

        ThisWorkbook.SaveAs NewName, ThisWorkbook.FileFormat    ' ? xlnormal

    End If

End Sub

Όσο για την εξαγωγή σε *.pdf θα πρέπει να διευκρινιστεί αν πρόκειται για ένα ή περισσότερα φύλλα.

Εκτός αυτού, ο κώδικας που παρουσιάζεις στο τελευταίο μήνυμα σου περιέχει κάποια σφάλματα.

Τάσος

με το pdf δεν εχω κανενα θεμα.μια χαρα το αποθηκευει.μονο το lookup θα αποθηκευω σε pdf,ενω σε excel θελω να αποθηκευω ολο το βιβλιο.
για το pdf εμενα δεν μου βγαζει θεμα

με τον κωδικα που μου εδωσες καθε φορα που παταω το κουμπι μου προσθετει ξανα την ημερομηνια

Σωτήρη, ο κώδικας που σου πρότεινα ήταν βασισμένος στον κώδικα που ανέβασες
και είναι λογικό να σου βγάζει 2 φορές την ημερομηνία στο όνομα του αρχείου έτσι που είναι στημένος.

Έστω ότι τρέχεις τον κώδικα μια φορά.

Το όνομα του βιβλίου που παραμένει ανοιχτό θα είναι 16_10_2013_όνομαΒιβλίου.xls
Αν λοιπόν ξανατρέξεις τον κώδικα στο βιβλίο 16_10_2013_όνομαΒιβλίου.xls που είναι ανοιχτό,
φυσικά θα σου προσθέσει και δεύτερη ημερομηνία στο ήδη υπάρχον όνομα δηλαδή το όνομα θα μετατραπεί σε: 16_10_2013_16_10_2013_όνομαΒιβλίου.xls .

Αν θέλεις το ίδιο βιβλίο να αποθηκεύεται περισσότερες φορές χωρίς να αλλάζει το όνομα του τότε:

Αντικατέστησε τη γραμμή: ThisWorkbook.SaveAs NewName, ThisWorkbook.FileFormat ' ? xlnormal

με τη γραμμή: ThisWorkbook.SaveCopyAs NewName

Για σένα αλλά και για τους υπόλοιπους φίλους που μας διαβάζουν, ο κώδικας που κάνει εξαγωγή σε *.pdf όλα τα φύλλα εργασίας ενός βιβλίου είναι:

Κώδικας:

Sub testPDFAllSheets()

    Dim xlFolder As String, wbName As String

    Dim i As Integer, NewName As String

    Dim fso As Object, wks As Worksheet

    xlFolder = ThisWorkbook.Path & "\"

    Set fso = CreateObject("Scripting.FileSystemObject")

    wbName = fso.GetBaseName(ThisWorkbook.FullName)

    On Error Resume Next

    For i = 1 To ThisWorkbook.Worksheets.Count

        Set wks = ThisWorkbook.Worksheets(i)

        ' Διάλεξε ποια περίπτωση σε εξυπηρετεί καλύτερα

        ' NewName = xlFolder & wbName & "_" & wks.Name & ".pdf"

        ' NewName = xlFolder & wbName & "_" & wks.Index & ".pdf"

        NewName = xlFolder & Format(Date, "dd_mm_yyyy") & "_" & wbName & "_" & wks.Index & ".pdf"

        If fso.FileExists(NewName) Then

            fso.DeleteFile NewName

        End If

        If Err <> 0 Then

            MsgBox "Σφάλμα: " & Err & vbLf & Err.Description

            Exit Sub

        Else

            wks.ExportAsFixedFormat _

                    Type:=xlTypePDF, _

                    Filename:=NewName, _

                    Quality:=xlQualityMinimum, _

                    IncludeDocProperties:=True, _

                    IgnorePrintAreas:=False, _

                    OpenAfterPublish:=False

        End If

    Next

End Sub

Φιλικά

Τάσος

δουλευει αψογα!!!!!!!!!!
αν και αυτο που θα πω ειναι εκτος topic. Ενα συμαντικο κομματι ακομα που μου εμεινε ειναι να κανω αναννεωση των δεδομενων στο φυλλο 1 (ετσι οπως το εχεις εσυ στο παραδειγμα σου) αν εχεις κατι σαν link για βοηθεια ευπροσδεκτο.
Ξεκιναω να το μελεταω και να το ψαχνω!!!

Και παλι ΕΥΧΑΡΙΣΤΩ ΠΑΡΑ ΠΟΛΥ!!!!