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/6502-apothikeysi-arxeioy.html)

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

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

Κώδικας:

ActiveWorkbook.SaveCopyAs (“C:\Users\Immortal\Desktop\Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm”)

Και να δημιουργήσω ένα νέο αντίγραφο στην επιφάνεια εργασίας αλλά όχι σε φάκελο.

Κώδικας:

ActiveWorkbook.SaveAs (“C:\Users\Immortal\Desktop\Το βιβλίο μου 2025.xlsm”)

Μπορεί μετά από αυτά να κλείνει το ανοιχτό βιβλίο;
Μπορεί αντί για την αποθήκευση απλά στο αρχείο, να αποθηκεύεται και να μεταφέρεται εκεί;
Μπορεί μετά από όλα αυτά να ανοίγει το νέο βιβλίο 2025;

Επίσης, εάν το βιβλίο χρησιμοποιηθεί σε άλλον υπολογιστή και χρειαστεί να γίνει αυτή η διαδικασία, θα πρέπει να αλλαχθούν τα paths εξ αρχής από εμενα ή υπάρχει κάτι γενικό που καθορίζει την επιφάνεια εργασίας για τους υπολογιστές;

Αρκετές οι ερωτήσεις μου κ σας ευχαριστώ προκαταβολικά!

Καλησπέρα σε όλους!

Νικο, ας υποθέσουμε ότι το τρέχον βιβλίο εργασίας (ActiveWorkbook) έχει το όνομα "Βιβλίο_1"
και το καινούργιο όνομα είναι "Βιβλίο_2".

Η συνάρτηση "ActiveWorkbook.SaveAs" αποθηκεύει το Βιβλίο_1 ως βιβλίο_2 λαμβάνοντας υπ όψη τις αλλαγές που έχουν γίνει στο Βιβλίο_1.

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

Η συνάρτηση "ActiveWorkbook.SaveCopyAs" απλά αντιγράφει το "Βιβλίο_1" με τις αλλαγές που τυχόν υπάρχουν αλλά δεν έχουν αποθηκευτεί με το όνομα "Βιβλίο_2" ενώ το "Βιβλίο_1" παραμένει ανοιχτό.

Ελπίζω να βοήθησα.

Καλή συνέχεια.

Τάσος

Καλησπέρα σας και καλή εβδομάδα,

Νίκο, σε συνέχεια του μηνύματος του Τάσου, παραθέτω και ένα παράδειγμα κώδικα:

Κώδικας:

Sub APO8HKEYSH()

    Dim MyPath As String

    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator

    

    ActiveWorkbook.SaveCopyAs MyPath & _

        "Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm"

    

    ActiveWorkbook.SaveAs MyPath & _

        "Το βιβλίο μου 2025.xlsm"

End Sub

Η μεταβλητή MyPath νομίζω πως απαντάει και στο ερώτημά σου για την εύρεση του φακέλου της επιφάνειας εργασίας σε άλλους υπολογιστές.

Καλησπέρα σας και καλή εβδομάδα!

Τάσο σε ευχαριστώ πολύ για τος αναλυτικές και κατανοητές πληροφορίες!

Χρήστο σε ευχαριστώ κι εσένα για την πρόταση που δίνεις, θα την δοκιμάσω και θα επανέλθω!
Μια λεπτομέρεια μόνο γιατί δεν το έχω δοκιμάσει ακόμη, στο παράδειγμα που δίνεις, κατά την λειτουργία του SaveCopyAs θα πρέπει ο φάκελος Αρχείο να υπάρχει ήδη στην επιφάνεια σωστά;

Ναι, πρέπει να υπάρχει αλλιώς εμφανίζεται σφάλμα.

Καλημέρα σε όλους!

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

Νομίζω στα πλαίσια αυτού του θέματος μπορούμε να δώσουμε παραδειγματικούς κώδικες που επιτρέπουν την δημιουργία φακέλου αν αυτός δεν υπάρχει.

Παράδειγμα με VBA.MkDir()

Η έκφραση MkDir "C:\Temp\TestFolder" θα δημιουργήσει τον φάκελο TestFolder μόνο αν υπάρχει ο φάκελος "C:\Temp\".
Διαφορετικά θα προκληθεί σφάλμα εκτέλεσης.
Αν δεν είναι σίγουρο ότι το "C:\Temp\" υπάρχει στο σύστημα, τότε θα πρέπει να τροποποιηθεί ο κώδικας έτσι που να ελέγξει την ύπαρξη κάθε φακέλου που αναφέρεται στη διαδρομή C:\Temp\TestFolder και αν δεν υπάρχει να τον δημιουργήσει.

Κώδικας:

Sub test()

    If Dir("C:\Temp", vbDirectory) = vbNullString Then MkDir "C:\Temp"

    If Dir("C:\Temp\TestFolder", vbDirectory) = vbNullString Then MkDir "C:\Temp\TestFolder"

End Sub

Παράδειγμα με Scripting.FileSystemObject (Προσθήκη αναφοράς: Tools>References > Microsoft Scripting Runtime)

Όπως και η προηγούμενη, η έκφραση FSO.CreateFolder "C:\Temp\TestFolder" θα δημιουργήσει τον φάκελο TestFolder μόνο αν υπάρχει ο φάκελος "C:\Temp\".

Κώδικας:

Sub test()

    Dim FSO    As New Scripting.FileSystemObject

    If Not FSO.FolderExists("C:\Temp\TestFolder") Then

        FSO.CreateFolder "C:\Temp\TestFolder"

    End If

End Sub

Παράδειγμα με Windows API: MakeSureDirectoryPathExists ()

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

Επιστρέφει True αν επιτύχει και False αν προκληθεί κάποιο σφάλμα κατά την εκτέλεση της.

Κώδικας:

#If VBA7 Then

    Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) _

             As LongPtr

#Else

    Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

#End If
 

Sub test()

    Dim success      As Boolean

    success = MakeSureDirectoryPathExists("C:\Temp\TestFolder")

    MsgBox success

End Sub

Παράδειγμα με Windows API: SHCreateDirectoryEx()

Η συνάρτηση αυτή δημιουργεί όλους τους φακέλους σε διαδρομές με περισσότερα επίπεδα, λειτουργεί με χαρακτήρες Unicode και προσφέρει αρκετές πληροφορίες σε περιπτώσεις που προκληθεί σφάλμα..

Κώδικας:

Option Explicit
 

#If VBA7 Then

    Private Declare PtrSafe Function SHCreateDirectoryEx _

             Lib "shell32" Alias "SHCreateDirectoryExW" _

             (ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As Any) As Long

#Else

    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _

             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

#End If
 

Function MakeSureFolderPathExists(Folderpath As String) As Boolean

    Const ERROR_SUCCESS As Long = &H0             'Η δημιουργία καταλόγου ήταν επιτυχής.

    Const ERROR_ACCESS_DENIED As Long = &H5       'Δεν ήταν δυνατή η δημιουργία καταλόγου, η πρόσβαση απορρίφθηκε.

    Const ERROR_BAD_PATHNAME As Long = &HA1       'Η παράμετρος pszPath ορίστηκε ως σχετική διαδρομή.

    Const ERROR_FILENAME_EXCED_RANGE As Long = &HCE 'Η διαδρομή που υποδεικνύεται από το pszPath είναι πολύ μεγάλη.

    Const ERROR_FILE_EXISTS As Long = &H50        'Ο κατάλογος υπάρχει.

    Const ERROR_ALREADY_EXISTS As Long = &HB7     'Ο κατάλογος υπάρχει.

    Const ERROR_INVALID_NAME As Long = &H7B       'Μη έγκυρο όνομα διαδρομής.
 

    Dim Result As Long
 

    Result = SHCreateDirectoryEx(ByVal 0&, StrPtr(Folderpath), ByVal 0&)

    

    Select Case Result

        Case ERROR_SUCCESS, ERROR_FILE_EXISTS, ERROR_ALREADY_EXISTS

            MakeSureFolderPathExists = True

            

        Case ERROR_ACCESS_DENIED: ShowMessageBox "Δεν ήταν δυνατή η δημιουργία {0}. Η πρόσβαση απορρίφθηκε.", Folderpath

        Case ERROR_BAD_PATHNAME: ShowMessageBox "Δεν είναι δυνατή η χρήση σχετικής διαδρομής: {0}", Folderpath

        Case ERROR_FILENAME_EXCED_RANGE: ShowMessageBox "Η διαδρομή είναι πολύ μεγάλη: {0}", Folderpath

        Case ERROR_INVALID_NAME: ShowMessageBox "Μη έγκυρο όνομα διαδρομής: {0}", Folderpath

        Case Else: ShowMessageBox "Απρόσμενο σφάλμα {0} κατά την επαλήθευση της διαδρομής", Result

    End Select

End Function
 

Private Sub ShowMessageBox(strMessage As String, Var As Variant)

    MsgBox Replace(Msg, "{0}", "'" & Var & "'"), vbExclamation, "Σφάλμα"

End Sub
 
 

Sub test()

    Dim FSO    As New Scripting.FileSystemObject

    Dim success As Boolean

    Dim MainFolderpath As String

    Dim SubFolderpath As String

    Dim FilePath As String

    

    MainFolderpath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    SubFolderpath = FSO.BuildPath(MainFolderpath, "Αρχείο")

    

    success = MakeSureFolderPathExists(SubFolderpath)

    

    If success Then

        

        FilePath = FSO.BuildPath(SubFolderpath, "Το βιβλίο μου 2025.xlsm")

        

        If FSO.FileExists(FilePath) Then

            

            MsgBox "Δέν έγινε αποθήκευση. Υπάρχει ήδη ένα αρχείο με το ίδιο όνομα.......", vbExclamation, "Σφάλμα"

            

        End If

        

    Else

        'Αν δεν είναι δυνατή η δημιουργία φακέλων σε κάποιο άλλο σημείο του συστήματος.

        MsgBox "Δεν μπόρεσε να δημιουργηθεί ο φάκελος. Απαιτούνται δικαιώματα διαχειριστή......", vbExclamation, "Σφάλμα"

    End If

End Sub

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

Καλή συνέχεια!

Τάσος

Καλή σας ημέρα!
Τάσο με σιγουριά μπορώ να σου πω πως χάθηκα με τόσα παραδείγματα και τόσες γραμμές :w00t:
Δοκίμασα το τελευταίο παράδειγμα (βασιζόμενος στο ότι εάν δεν υπάρχει ο φάκελος, να δημιουργηθεί), σε module (εκεί πρέπει να μπει; Ή μέσα στο φύλλο;) και κοκκινίζει αυτό

Κώδικας:

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _

             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Να με συγχωρείτε για την ασχετοσύνη μου! Κάποια πράγματα δεν τα καταλαβαίνω καθόλου:w00t:
Όπως και να έχει σας ευχαριστώ για τις προτάσεις και τον χρόνο σας!

Καλημέρα Νίκο.

Οι οδηγίες #If και #End If είναι προεπεξεργαστικές οδηγίες (preprocessor directives) στη VBA.

Χρησιμοποιούνται για να ελέγξουν ποια τμήματα του κώδικα θα συμπεριληφθούν κατά τη μεταγλώττιση σε κώδικα μηχανής, ανάλογα με τις καθορισμένες συνθήκες. Αυτές οι οδηγίες δεν εκτελούνται κατά τη διάρκεια της εκτέλεσης του κώδικα, αλλά κατά τη φάση της μεταγλώττισης.

Χρήση των #If και #End If

Η οδηγία #If ελέγχει μια συνθήκη κατά τη φάση της μεταγλώττισης και, αν η συνθήκη είναι αληθής, συμπεριλαμβάνει το μπλοκ του κώδικα που ακολουθεί.

Η οδηγία #Else χρησιμοποιείται για να καθορίσει εναλλακτικό μπλοκ κώδικα, αν η συνθήκη του #If είναι ψευδής.

Η οδηγία #End If χρησιμοποιείται για να δηλώσει το τέλος του μπλοκ κώδικα που ελέγχεται από το #If.

Παράδειγμα

Ας δούμε ένα παράδειγμα για να κατανοήσουμε καλύτερα τη χρήση αυτών των οδηγιών:

Κώδικας:

#If VBA7 Then  

   ' Αν  η έκδοση Office είναι 64 bit (VBA7) τότε

   

    Private Declare PtrSafe Function SHCreateDirectoryEx _

             Lib "shell32" Alias "SHCreateDirectoryExW" _

             (ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As Any) As Long
 
 #Else 

    'Αν  η έκδοση Office είναι 32 bit (VBA6) τότε
 
     Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _

             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

              ' Η σουίτα Office που χρησιμοποιείς είναι 64 Bit.
 
 
 #End If

Η μια από τις δύο συναρτήσεις ανάλογα την έκδοση Microsoft Office Θεωρείται από τον VBE άκυρη και γι αυτό την "κοκκινίζει".

Αυτό δε σημαίνει ότι είναι σφάλμα αφού θα αγνοηθεί κατά τη φάση της μεταγλώττισης.

Προτείνω να βάλεις όλο τον κώδικα εκτός το Sub Test() σε μια λειτουργική μονάδα (Module) και το Sub Test() όπου χρειαστεί.

Καλή συνέχεια!

Τάσος

Καλησπέρα!
Τάσο έχω τοποθετήσει τον κώδικα σύμφωνα με τις οδηγίες σου!
Όταν τον τρέχω δημιουργεί τον φάκελο Αρχείο, αλλά δεν αποθηκεύει το αρχείο κάπου, ούτε με το παλιό όνομα ούτε με το νέο :022:

Παράθεση:

Αρχική Δημοσίευση από ChrisGT7 (Μήνυμα 35749)

Κώδικας:

Sub APO8HKEYSH()

    Dim MyPath As String

    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator

    

    ActiveWorkbook.SaveCopyAs MyPath & _

        "Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm"

    

    ActiveWorkbook.SaveAs MyPath & _

        "Το βιβλίο μου 2025.xlsm"

End Sub

Χρήστο καλησπέρα! Υπάρχει περίπτωση στα Save που έχω κοκκινίσει το 2024 και το 2025, να έρχonται από ένα κελί το οποίο έχω ονομάσει LastYear για το 2024 και NextYear για το 2025;

Καλησπέρα Νίκο,

Δοκίμασε τον παρακάτω κώδικα:

Κώδικας:

Option Explicit
 

Sub APO8HKEYSH()

    Dim MyPath As String

    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator

    

    With ActiveWorkbook

        .SaveCopyAs MyPath & [LastYear]

        .SaveAs MyPath & [NextYear]

    End With

End Sub

Σύμφωνα με όσα προαναφέρθηκαν παραπάνω και το παράδειγμά σου:
- Στο LastYear θα υπάρχει η τιμή Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm
- Στο NextYear Το βιβλίο μου 2025.xlsm
- Και στην επιφάνεια ο φάκελος Αρχείο.

Χρήστο καλησπέρα
Νομίζω πως όλα δουλεύουν άριστα :thumbup1:
Σας ευχαριστώ πολύ για την βοήθεια Χρήστο και Τάσο να είστε καλά!
Καλό βράδυ :happy:

Παράθεση:

Αρχική Δημοσίευση από ChrisGT7 (Μήνυμα 35757)

Καλησπέρα Νίκο,

Δοκίμασε τον παρακάτω κώδικα:

Κώδικας:

Option Explicit
 

Sub APO8HKEYSH()

    Dim MyPath As String

    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator

    

    With ActiveWorkbook

        .SaveCopyAs MyPath & [LastYear]

        .SaveAs MyPath & [NextYear]

    End With

End Sub

Καλημερα Χρήστο, καλό μήνα με υγεία!
Ολοκληρώνοντας κάτι έρχονται ιδέες και για αλλά πράγματα κι έτσι σκέφτηκα πως με τον ίδιο ακριβώς τρόπο, θα μπορούσα να αποθηκεύω και τις ενεργές περιοχές κάποιων φύλλων σε μορφή pdf, αυτό που πρόκειται να εκτυπωθεί δηλαδή.
Οπότε, ακολούθησα τις οδηγίες σου για άλλη μια φορά, γίνεται η διαδικασία κ αποθηκεύονται τα pdf στην διαδρομή που έχω ορίσει.
Το πρόβλημα που συναντώ είναι πως ενώ το pdf αρχείο υπάρχει, δεν μου το ανοίγει.
Μήπως με τη συγκεκριμένη διαδικασία δεν αποθηκεύονται οι ενεργές περιοχές ως έγγραφα αλλά τα φύλλα του βιβλίου γενικότερα;

Καλησπέρα Νίκο,

Ελπίζω ο ο παρακάτω κώδικας να σε καλύψει προσαρμόζοντάς τον στο δικό σου:

Κώδικας:

    [B10:D50].ExportAsFixedFormat _

        Type:=xlTypePDF, _

        Filename:=MyPath & "MyFile.pdf", _

        Quality:=xlQualityStandard, _

        IncludeDocProperties:=True, _

        IgnorePrintAreas:=False, _

        OpenAfterPublish:=True

Ο παρακάτω κώδικας αποθηκεύει το εύρος B10:D50 (το αλλάζεις σύμφωνα με τις ανάγκες σου) ως αρχείο pdf στη διαδρομή που του έχεις θέσει στη μεταβλητή MyPath, όπως είχαμε αναφέρει τις προάλλες.

Το όρισμα OpenAfterPublish με True ανοίγει το αρχείο μετά την αποθήκευση ενώ με False παραμένει κλειστό.

Καλημέρα Χρήστο.
Θα το δοκιμάσω και θα σε ενημερώσω.
Όσον αφορά το [B10:D50], υπάρχει άλλος τρόπος να δέχεται η εντολή την ενεργή περιοχή του φύλλου;

Καλημέρα Νίκο,

Λέγοντας "ενεργή περιοχή του φύλλου", θεωρώ πως εννοείς το επιλεγμένο εύρος.

Δοκίμασε αντί εύρος να βάλεις τη λέξη Selection.

Χρήστο δεν ξέρω αν εννοούμε το ίδιο :005:
Πιθανόν όχι, γιατί το Selection αποθηκεύει το κελί που έχω επιλεγμένο εκείνη την στιγμή. (Αυτά συμβαίνουν όταν μπλέκομαι με τα πίτουρα :a068:)
Εννοώ αυτό που ορίζω ως περιοχή εκτύπωσης.

Νομίζω τώρα είναι πιο ξεκάθαρο! :003:

Οπότε αντί για Selection, δοκίμασε αυτό το εύρος να κάνεις σε pdf: Range(ActiveSheet.PageSetup.PrintArea)

Να είσαι καλά βρε Χρήστο σε ευχαριστώ!
Τώρα ξετυλίχθηκε το κουβάρι κ βρέθηκε η άκρη :thumbup: