Ανανέωση ιστοσελίδας

[agrbita]

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

χρησιμοποίησα κώδικα από το 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

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

ευχαριστώ.

[kapetang]

Καλησπέρα

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

[agrbita]

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

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

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

ευχαριστώ.

[agrbita]

Υπάρχει συνάρτηση ή VBA η οποία να ελέγχει κατά την πληκτρολόγηση στην στήλη ΑΦΜ (ή περιοχή "afm") το νούμερο του ΑΦΜ, αν είναι σωστό ; ή αν είναι εννέα τα ψηφία ;.

[kapetang]

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

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

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

2) Την επικύρωση του ΑΦΜ.

[Spirosgr]

Καλημέρα.

Πριν απ' όλα,
για θέματα ΑΦΜ, υπάρχουν πολλά άρθρα που μπορεί να βρει κανείς,
με αναζήτηση στο 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]

Βάλτε το αρχείο, σε ένα φάκελο του υπολογιστή σας
ή και σε εξωτερικό σκληρό, ή stick κλπ, και ελέγξτε τι κάνει...

[kapetang]

Τάσο τώρα πρόσεξα ότι πατώντας το κουμπί «ΕΚΚΑΘΆΡΙΣΗ» διαγράφονται κάποια στοιχεία τα οποία θα προκαλέσουν την εκτέλεση κώδικα (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

Έλεγξε αν συμπλήρωσα σωστά τις περιοχές.

[kapetang]

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

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

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

[agrbita]

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

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

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

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

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

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

Σπύρο και Γιώργο και πάλι ευχαριστώ.