
16-10-13, 01:05
|
 | Διαχειριστής Όνομα: Τάσος Φιλοξενιδης Έκδοση λογισμικού 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 Ανάπτυξη επαγγελματικών εφαρμογών |