Αυτόματη αντιγραφή φύλλου Excel σε νέο βιβλίο
Όταν η αντιγραφή ενός υπολογιστικού φύλλου σε νέο βιβλίο εργασίας αποτελεί μέρος ενός αυτοματισμού, ο παρακάτω κώδικας μπορεί να βοηθήσει:
Σενάριο: - Διαδρομή φακέλου για τα αρχεία προς αποθήκευση: "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
| 