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

[sotisanis]

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

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

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

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

[Tasos]

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

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

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

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

Τάσος

[sotisanis]

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

Καθε φορα που παταω αποθηκευση (φτιαγμενο κουμπι με 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

[Tasos]

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

Δεν κατάλαβα όμως: Θέλεις να αποθηκεύσεις όλα τα φύλλα εργασίας του βιβλίου σε *.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 θα πρέπει να διευκρινιστεί αν πρόκειται για ένα ή περισσότερα φύλλα.

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

Τάσος

[sotisanis]

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

[sotisanis]

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

[Tasos]

Σωτήρη, ο κώδικας που σου πρότεινα ήταν βασισμένος στον κώδικα που ανέβασες
και είναι λογικό να σου βγάζει 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

Φιλικά

Τάσος

[sotisanis]

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

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