[VBA] Αυτόματη αντιγραφή φύλλου Excel σε νέο βιβλίο

[Tasos]

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

Σενάριο:

• Διαδρομή φακέλου για τα αρχεία προς αποθήκευση: "C:\foldername\"
• Το όνομα του φύλλου προς αποθήκευση: "Μετρήσεις" (Κωδικό όνομα = wksValues)
• Όνομα αποθήκευσης: "C:\foldername\" & τιμή από το κελί "A1" & τρέχουσα ημερομηνία και ώρα
  
• Μορφή αρχείου: *.xlsx

Option Explicit

Sub ExportWorksheet()
    Dim wb As Workbook, wbName As String
    Const xlsxPath = "C:\foldername\"    ' Η διαδρομή του φακέλου

    If Dir(xlsxPath, vbDirectory) = vbNullString Then

        ' ειδοποιεί τον χρήστη ότι ο φάκελος δεν υπάρχει
        MsgBox "Ο φάκελος '" & xlsxPath & "' δεν υπάρχει!" & vbLf & _
               "Θα πρέπει να τον δημιουργήσετε για να συνεχίσετε.", vbExclamation
        Exit Sub    'τερματίζει τη διαδικασία

    Else
        If Trim(Range("A1")) <> vbNullString Then    ' αν το κελί A1 δεν είναι κενό
            wbName = Range("A1") & _
                          " (" & Format(Now, "dd-mm-yy hh-mm") & ")" & ".xlsx"
            'δημιουργεί το όνομα με βάση την τιμή του κελιού A1

            ' διαφορετικά (αν το κελί A1 είναι κενό)
        Else
            'δημιουργεί το όνομα με βάση τον τρέχοντα μήνα
            wbName = Format(Now, "mmmm") & _
                          " (" & Format(Now, "dd-mm-yy hh-mm") & ")" & ".xlsx"
        End If
    End If

    'αν το όνομα του αρχειου προς εξαγωγή ήδη υπάρχει τότε με εμφάνιση μηνύματος επιλογής (Ναι/Όχι)
    'αποφασίζεται από στο χρήστη η αντικατάσταση του υπάρχοντος αρχείου
    If Dir(xlsxPath & wbName, vbDirectory) <> vbNullString Then
        If MsgBox("Το αρχείο '" & wbName & "' υπάρχει ήδη στο φάκελο '" & xlsxPath & "'" & vbLf & _
                  "Θέλετε να το αντικαταστήσετε;", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then

            '******αν ο χρήστης στο μήνυμα επιλογής (Ναι/Όχι) επιλέξει "Ναι"

            'αποτρέπει τη διακοπή εκτέλεσης του κώδικα αν προκληθεί σφάλμα.
            On Error Resume Next

            'διαγράφει το αρχείο
            Kill xlsxPath & wbName

            ' αν προκληθεί σφάλμα με το νούμερο 70 (δεν επιτρέπεται η πρόσβαση στο αρχείο προς διαγραφή)
            If Err = 70 Then
                MsgBox "Δεν είναι δυνατή η αντικατάσταση του αρχείου '" & wbName & "'" & vbLf & _
                       "επειδή χρησιμοποιείται από κάποιο πρόγραμμα ή χρήστη." _
                       & vbLf & "Η διαδικασία θα διακοπεί.", vbInformation
                Exit Sub
                ' αν προκληθεί οποιοδήποτε άλλο σφάλμα
            ElseIf Err <> 0 Then
                MsgBox "Σφάλμα " & Err & vbLf & Err.Description, vbExclamation

                'τερματίζει τη διαδικασία
                Exit Sub
            End If

        Else    '******αν ο χρήστης στο μήνυμα επιλογής (Ναι/Όχι) επιλέξει "Όχι" ή κλείσει το μήνυμα

            Exit Sub    'τερματίζει τη διαδικασία
        End If
    End If

    With Application
        'διακόπτει την ανανέωση της οθόνης μέχρι το τέλος της διαδικασίας
        .ScreenUpdating = False

        'δεν εμφανίζει το παράθυρο στην μπάρα των Windows (δεν ισχύει για παράθυρα που είναι ήδη ανοιχτά)
        .ShowWindowsInTaskbar = False

        'διακόπτει τον αυτόματο υπολογισμό της εφαρμογής
        .Calculation = xlCalculationManual

        'wksValues= το κωδικό όνομα του φύλλου προς αντιγραφή "Μετρήσεις"
        'Συνιστάται να καλούμε τα φύλλα που μας είναι γνωστά κατά τη σχεδίαση της εφαρμογής
        'με το κωδικό τους όνομα. Έτσι, τυχόν μετονομασία ή μετακίνηση του φύλλου δεν θα έχει
        'επιπτώσεις στην εκτέλεση του κώδικα αφού τό κωδικό του όνομα παραμένει ως έχει.
        'Μετονομάζουμε λοιπόν στον Project Explorer το φύλλο "Sheet1(Μετρήσεις) σε wksValues
        'Καλό είναι να κάνουμε το ίδιο και με τα υπόλοιπα φύλλα που εμπλέκονται στο έργο VBA
        
        wksValues.Copy 'Δημιουργεί αντίγραφο του φύλλου σε νέο βιβλίο

        Set wb = ActiveWorkbook

        'αποθηκεύει το βιβλίο στην προεπιλεγμένη διαδρομή
        wb.SaveAs Filename:=xlsxPath & wbName, FileFormat:=xlOpenXMLWorkbook

        'κλείνει το νέο βιβλίο
        wb.Close SaveChanges:=False

        .ShowWindowsInTaskbar = True
        'επαναφέρει τη ρύθμιση εμφανίσης των παραθύρων της εφαρμογής στην μπάρα των Windows

        .Calculation = xlCalculationAutomatic
        'επαναφέρει τον αυτόματο υπολογισμό της εφαρμογής

        .ScreenUpdating = True
        'επιτρέπει/επαναφέρει την ανανέωση της οθόνης. 

        'αν για κάποιο λόγο έχει προκληθεί σφάλμα κατά την αποθήκευση
        If Err <> 0 Then
            MsgBox "Σφάλμα " & Err & vbLf & Err.Description, vbExclamation
        Else
            ' Μήνυμα  επιτυχούς δημιουργίας του αρχείου
            MsgBox "Το αρχείο '" & wbName & "' δημιουργήθηκε στο φάκελο '" & _
                   xlsxPath & "'", vbInformation

        End If
    End With

End Sub