Forum

Αναζήτηση στο ms-office.gr

Πάμε!
ms-office.gr > Forum > Microsoft Excel > Excel - Ερωτήσεις / Απαντήσεις > [VBA] Αποθήκευση Φύλλου εργασίας με επιλογή θέσης

Excel - Ερωτήσεις / Απαντήσεις Ότι έχει σχέση με συναρτήσεις, μορφοποίηση, εκτυπώσεις γραφήματα κτλ.

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 16-09-18, 10:55
Όνομα: Τάσος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 06-08-2011
Μηνύματα: 28
Προεπιλογή Αποθήκευση Φύλλου εργασίας με επιλογή θέσης

Κύριοι καλημέρα σας,

χρησιμοποίησα κώδικα από το Forum για την αποθήκευση του βιβλίου εργασίας και τον προσάρμοσα λίγο, όμως επειδή μεταφέρω το αρχείο και σε άλλους Υπολογιστές, θα πρέπει να αλλάζω την γραμμή ,
myPath = "C:\WINDOWS\Personal\ΥΕΒ\2018\" στον αντίστοιχο φάκελο που έχω σε κάθε Υπολογιστή.
Παραθέτω τον κώδικα :
Sub mySaveAsExcel()
Dim j As Integer
Dim myPath As String
'Dim mySheet As String
Dim myCell As String

Dim BookName As String

Dim IllegalCharacters As Variant

IllegalCharacters = VBA.Array(">", "<", "?", "[", "]", ":", "|", "*", "/", "\", """")

myPath = "C:\WINDOWS\Personal\ΥΕΒ\2018\"
'mySheet = ActiveSheet.Φύλλο3
myCell = Φύλλο3.Range("A1").Value

BookName = myCell & " " & Format(Now(), "dd-mm-yyyy_hh:mm:ss") & ".xls"

For j = LBound(IllegalCharacters) To UBound(IllegalCharacters)
BookName = VBA.Replace(BookName, IllegalCharacters(j), "")
Next j
ActiveWorkbook.SaveAs Filename:=myPath & BookName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

Το ερώτημα λοιπόν είναι:

1) Να γίνεται πάντα η αποθήκευση στον φάκελο "\τα έγγραφά μου (documents)\ΥΕΒ\2018". Θα πρέπει λοιπόν ο κώδικας να ελέγχει αν υπάρχει ο φάκελος "\ΥΕΒ\2018\" και αν δεν υπάρχει να τον δημιουργεί σε κάθε υπολογιστή που εγκαθιστώ το αρχείο. Στους υπολογιστές έχω windows xp, 7 και 10 και η λογική των φακέλων είναι διαφορετική (πχ. c:\user\user1\docouments\ΥΕΒ\2018)

2) Να ελέγχει στο myCell = Φύλλο3.Range("A1").Value, την τιμή στο "Α1" και αν είναι κενό να διακόπτετε ο κώδικας και να εμφανίζει σχετικό μήνυμα (πχ."τί κάνεις τώρα;").

3) στον κώδικα :

Sub MyClear()

Φύλλο2.Range("b4:b7").ClearContents
Φύλλο2.Range("b9:b11").ClearContents
Φύλλο2.Range("b13").ClearContents
Φύλλο2.Range("b15:b16").ClearContents

End Sub

μπορώ να γράψω μία γραμμή για αυτές τις περιοχές κελιών;

ευχαριστώ.
Απάντηση με παράθεση
  #2  
Παλιά 16-09-18, 19:36
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 3.161
Προεπιλογή

Καλησπέρα

Τάσο, ανέβασε ένα δείγμα αρχείου, ώστε να διευκρινιστούν, η θέση του κώδικα (Module ή φύλλο), ο τρόπος εκτέλεσής του κλπ.
Απάντηση με παράθεση
  #3  
Παλιά 16-09-18, 21:29
Όνομα: Τάσος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 06-08-2011
Μηνύματα: 28
Προεπιλογή

Γιώργο καλησπέρα,

Ανεβάζω σχετικό υπόδειγμα με τον κώδικα που έχει το αρχείο.

οποιαδήποτε παρατήρηση και επίλυση δεκτή.

ευχαριστώ.
Συνημμένα Αρχεία
Τύπος Αρχείου: xls mySaveAsExcel1.xls (126,0 KB, 12 εμφανίσεις)
Απάντηση με παράθεση
  #4  
Παλιά 16-09-18, 23:15
Όνομα: Τάσος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 06-08-2011
Μηνύματα: 28
Προεπιλογή

Υπάρχει συνάρτηση ή VBA η οποία να ελέγχει κατά την πληκτρολόγηση στην στήλη ΑΦΜ (ή περιοχή "afm") το νούμερο του ΑΦΜ, αν είναι σωστό ; ή αν είναι εννέα τα ψηφία ;.
Απάντηση με παράθεση
  #5  
Παλιά 17-09-18, 08:07
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 3.161
Προεπιλογή

Τάσο, κάνε δοκιμές στο συνημμένο.

Συγκεκριμένα:

1) Δοκίμασε τον κώδικα αποθήκευσης.

2) Την επικύρωση του ΑΦΜ.
Συνημμένα Αρχεία
Τύπος Αρχείου: xls mySaveAsExcel2.xls (157,0 KB, 25 εμφανίσεις)

Τελευταία επεξεργασία από το χρήστη kapetang : 17-09-18 στις 08:32. Αιτία: Βελτίωση κώδικα
Απάντηση με παράθεση
  #6  
Παλιά 17-09-18, 08:42
Το avatar του χρήστη Spirosgr
Συντονιστής
Όνομα: Σπύρος Τσιλιγιάννης
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2010, Ms-Office 2013, Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 22-11-2011
Περιοχή: Αθήνα
Μηνύματα: 2.402
Προεπιλογή

Καλημέρα.

Πριν απ' όλα,
για θέματα ΑΦΜ, υπάρχουν πολλά άρθρα που μπορεί να βρει κανείς,
με αναζήτηση στο forum.
Πιθανό να δείτε και περιπτώσεις που δεν σκεφτήκατε, όπως
αυτόματη συμπλήρωση μηδέν, ή ΑΦΜ με δύο μηδενικά μπροστά κλπ.

Μια παρατήρηση στον κώδικα του Γιώργου.
Η αποθήκευση στα Documents, δεν θα δουλέψει με ΧΡ, γιατί εκεί έχουμε
Documents and Settings

Γι' αυτό...
Ή θα βάλουμε μια Function, να ελέγχει το λειτουργικό και με βάση
το αποτέλεσμα, θα διαμορφώσουμε το path, manual με
If αυτό το λειτουργικό, βάλε ...το Χ path
If το άλλο βάλε...το Ψ path ή
θα βάλουμε το ThisWorkbook.Path, όπως θα το δούμε παρακάτω...

Να ξεκινήσουμε από το προηγούμενο post και το τρίτο ερώτημα.
Κώδικας:
Sub MyClear()
    Sheet1.Range("b4:b7,b9:b11,b13,b15:b16").ClearContents
    Sheet2.Range("b4:b7,b9:b11,b13,b15:b16").ClearContents
End Sub
Αυτός είναι ο τρόπος σύνταξης, για πολλαπλές περιοχές ανά φύλλο.
Αντικαθιστούμε τα Sheet1,Sheet2 με το κωδικό όνομα των πραγματικών φύλλων.

Πάμε τώρα στον κύριο κώδικα, mySaveAsExcel

Κατ' αρχάς στο τελείωμα του κώδικα, την ώρα που σώζει
επειδή πολλά έχουν δει τα μάτια μου, αντί του ActiveWorkbook
προτιμώ το ThisWorkbook.

Ανεξάρτητα με το λειτουργικό όποιων υπολογιστών, καλό είναι να ακολουθήσουμε το εξής:

Πάμε σε ένα φάκελο της επιλογής μας (πχ Documents ή παλιότερα Documents and settings)
και βάζουμε το κύριο βιβλίο μας.
*Optional, ανοίγουμε μια shortcut, στην επιφάνεια εργασίας.

Με αυτόν τον τρόπο, οι φάκελοι θα δημιουργηθούν στον επιλεγμένο...
με την χρήση ThisWorkbook.Path, στον κώδικα

Τώρα, πάμε στην επεξήγηση...

Έχω βάλει κάπου (οπουδήποτε) το βιβλίο.
Εκεί λοιπόν θέλω να έχω:
Ένα φάκελο ΥΕΒ
Μέσα σε αυτόν, ένα φάκελο 2018 (το αλλάζω κάθε χρονιά) και
Μέσα σε αυτόν ένα αντίγραφο του βιβλίου με όνομα από το κελί a1
Κώδικας:
Option Explicit
Const myMainFolderName As String = "ΥΕΒ"
Const mySubFolderName As String = "2018"
Dim BadChars As Variant
'------------------------------------------------------------
Sub mySaveAsExcel()
    Dim j As Integer
    Dim myCell As Range
    Dim BookName As String, myPath As String

    'Αν το κελί a1, είναι κενό = Έξοδος

    Set myCell = Sheet1.Range("A1")
    If Len(myCell.Value) = 0 Then
        MsgBox "Γράψε ό,τι θέλεις..."
        Exit Sub
    End If

    'Αν δεν υπάρχει φάκελος ΥΑΒ = Δημιουργία

    If Len(Dir(ThisWorkbook.Path & "\" & myMainFolderName, vbDirectory)) = 0 Then
        MkDir ThisWorkbook.Path & "\" & myMainFolderName
    End If

    'Αν δεν υπάρχει υποφάκελος 2018 = Δημιουργία

    If Len(Dir(ThisWorkbook.Path & "\" & myMainFolderName & "\" & mySubFolderName, vbDirectory)) = 0 Then
        MkDir ThisWorkbook.Path & "\" & myMainFolderName & "\" & mySubFolderName
    End If

    'Αντικατάσταση μη επιτρεπτων χαρακτήρων (κελί a1) με κενό (όχι space, αλλά τίποτα...)

    myPath = ThisWorkbook.Path & "\" & myMainFolderName & "\" & mySubFolderName
    BookName = Trim(myCell.Value) & " " & Format(Now(), "dd-mm-yyyy_hh:mm:ss") & ".xls"
    BadChars = VBA.Array(">", "<", "?", "[", "]", ":", "|", "*", "/", "\", """")

    For j = LBound(BadChars) To UBound(BadChars)
        BookName = VBA.Replace(BookName, BadChars(j), "")
    Next j

    'Αποθήκευση αντιγράφου

    ThisWorkbook.SaveCopyAs Filename:=myPath & "\" & BookName
End Sub
Σημειώσεις:
*Αντικαθιστούμε το Sheet1,με το κωδικό όνομα του φύλλου.
*Αντικαθιστούμε τις σταθερές φακέλων με όποιο τίτλο θέλουμε.
*Αντικαθιστούμε την κατάληξη .xls, με, πχ .xlsm (optional)
*Το κύριο βιβλίο, παραμένει να το κάνουμε ό,τι θέλουμε
*Αν θέλουμε τα νέα αρχεία να αντικαθιστούν τα παλιά,
δεν θα βάλουμε ώρα ή και ημέρα (optional) στον τίτλο αρχείου και
θα απενεργοποιήσουμε τα Alerts

Τελευταία επεξεργασία από το χρήστη Spirosgr : 17-09-18 στις 09:10. Αιτία: Συμπληρωματικές σημειώσεις
Απάντηση με παράθεση
  #7  
Παλιά 17-09-18, 08:59
Το avatar του χρήστη Spirosgr
Συντονιστής
Όνομα: Σπύρος Τσιλιγιάννης
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2010, Ms-Office 2013, Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 22-11-2011
Περιοχή: Αθήνα
Μηνύματα: 2.402
Προεπιλογή

Βάλτε το αρχείο, σε ένα φάκελο του υπολογιστή σας
ή και σε εξωτερικό σκληρό, ή stick κλπ, και ελέγξτε τι κάνει...
Συνημμένα Αρχεία
Τύπος Αρχείου: xls main Excel.xls (74,0 KB, 23 εμφανίσεις)
Απάντηση με παράθεση
  #8  
Παλιά 17-09-18, 11:53
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 3.161
Προεπιλογή

Τάσο τώρα πρόσεξα ότι πατώντας το κουμπί «ΕΚΚΑΘΆΡΙΣΗ» διαγράφονται κάποια στοιχεία τα οποία θα προκαλέσουν την εκτέλεση κώδικα (GetMonths, Worksheet_Change), που δε θέλουμε να εκτελεστεί σ' αυτή τη φάση, επειδή μπορεί να προκληθούν λάθη.

Παίρνοντας υπόψη και την πρόταση του Σπύρου, θα πρέπει να διαμορφώσεις τον κώδικα της διαδικασίας MyClear ως εξής:

Κώδικας:
Sub MyClear()
    On Error GoTo errHandler
    
    Application.EnableEvents = False
    Φύλλο4.Range("b3:q40").ClearContents
    Φύλλο5.Range("b4:b7, b9:b11, b13,b15:b16").ClearContents
    Φύλλο6.Range("b6:g200,j6:j200").ClearContents

exitSub:
    Application.EnableEvents = True
    Exit Sub
errHandler:
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number
    Resume exitSub
End Sub
Έλεγξε αν συμπλήρωσα σωστά τις περιοχές.
Απάντηση με παράθεση
  #9  
Παλιά 17-09-18, 17:18
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 3.161
Προεπιλογή

Τάσο, ο κώδικας στο φύλλο «ΕΙΣΑΓΩΓΗ ΠΟΛΛΩΝ», που ελέγχει το ΑΦΜ, παρουσιάζει κάποια ελαττώματα (πχ μπορούμε να επικολλήσουμε πολλά ΑΦΜ χωρίς έλεγχο).

Προτείνω να τον αλλάξεις με τον:

Κώδικας:
Const strAFM As String = "k3:k1000" ' περιοχή αναγραφής ΑΦΜ

Private Sub Worksheet_Change(ByVal Target As Range)
    'Έλεγχος ΑΦΜ
    
    Dim rng As Range, AFM As String, rngTomi As Range
    Set rng = Range(strAFM)
    Set rngTomi = Intersect(Target, rng)
    If rngTomi Is Nothing Then Exit Sub
    
    If rngTomi.Count <> 1 Then
        rngTomi.ClearContents
        Exit Sub
    End If
    If Trim(Target.Value) = "" Then Exit Sub
    
    AFM = Right("000000000" & Target.Value, 9)
   
    If isAFM(AFM) = False Then
        MsgBox "Άκυρο ΑΦΜ"
        Target.Activate
        Exit Sub
    End If
End Sub
Απάντηση με παράθεση
  #10  
Παλιά 17-09-18, 20:15
Όνομα: Τάσος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 06-08-2011
Μηνύματα: 28
Προεπιλογή

Γιώργο καλησπέρα, σε ευχαριστώ πολύ για την βοήθεια. Ο κώδικας για το ΑΦΜ στο φύλλο "ΕΙΣΑΓΩΓΗ ΠΟΛΛΩΝ", δούλεψε άψογα. Προσάρμοσα και τον κώδικα MyClear και όλα δουλεύουν τέλεια.

Σπύρο καλησπέρα. Πρέπει να σου πω ότι η ιδέα σου για την αποθήκευση στο ThisWorkbook.Path είναι καταπληκτική. Ο κώδικας δούλεψε άριστα Έσβησα την ημερομηνία από το BookName και ΝΑΙ αποθηκεύει το αρχείο μόνο μια φορά (διαγράφει το προηγούμενο).

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

Απλά ένα ΜΕΓΑΛΟ ευχαριστώ.

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

Σπύρο θα ψάξω, γιατί κάπου το έχω δει, αν στον κώδικά σου μπορεί να δημιουργείται και ένας ακόμα φάκελος με το όνομα του χρήστη (πχ. myCell ) όπου εκεί μέσα θα αποθηκεύεται το αρχείο BookName.

Σπύρο και Γιώργο και πάλι ευχαριστώ.
Απάντηση με παράθεση
Απάντηση στο θέμα

Εργαλεία Θεμάτων
Τρόποι εμφάνισης

Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
Εξαγωγή αρχείου σε μορφή pdf με επιλογή θέσης και με alarm ύπαρξης ίδιου ονόματος ΤΙΜΟΣ Access - Ερωτήσεις / Απαντήσεις 8 05-05-17 18:06
Ενεργοποιηση φυλλου εργασιας απο τιμη σε κελι dimtsam Visual Basic for Applications (VBA) 1 25-03-16 13:04
[Excel07] ΑΠΟΘΗΚΕΥΣΗ ΜΕΡΟΥΣ ΦΥΛΛΟΥ ΕΡΓΑΣΙΑΣ ΣΕ CVS ΜΕ BUTTON smasak Excel - Ερωτήσεις / Απαντήσεις 8 01-12-15 12:13
[VBA] Αποθήκευση βιβλίου με το τρέχον όνομα φύλλου και φίλτρο ΧρύσαΚ Excel - Ερωτήσεις / Απαντήσεις 4 09-05-14 06:48
[VBA] Δημιουργία Φύλλου Εργασίας με κώδικα othonas Excel - Ερωτήσεις / Απαντήσεις 3 17-05-13 07:14


Η ώρα είναι 06:27.