Εμφάνιση ενός μόνο μηνύματος
  #7  
Παλιά 16-10-13, 01:05
Το avatar του χρήστη Tasos
Tasos Ο χρήστης Tasos δεν είναι συνδεδεμένος
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.030
Προεπιλογή

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

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών
Απάντηση με παράθεση