[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