[VBA] Αποθήκευση και αρίθμηση αρχείων

[Lokos]

Καλημέρα σε όλους!

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

Το όνομα του νέου αυτού αρχείου θα πρέπει να έχει το πρόθεμα „001_“, & Όνομα αρχείου.
Παράδειγμα:

001_Όνομα αρχείου.xls, 002_Όνομα αρχείου.xls κοκ. δηλ. το πρόθεμα να αυξάνεται κατά μια μονάδα κάθε φορά που αποθηκεύω ένα νέο βιβλίο εργασίας.

Επίσης θα ήθελα από το φύλλο που θα αντιγραφεί σε νέο βιβλίο να αφαιρεθεί κώδικας που περιέχει.

Μέχρι τώρα τη διαδικασία αυτή την κάνω με το χέρι!!

Παρακαλώ τα φώτα σας!

Ευχαριστώ εκ των προτέρων

Γιώργος

[nisgia]

Καλησπέρα Γιώργο!

Δες ένα παράδειγμα στο συνημμένο που κάνει ότι ακριβώς ζητάς.

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

Για την αφαίρεση του κώδικα δεν χρησιμοποιώ αναφορές στα συστατικά του VBProject
αλλά κάνω απλή αντιγραφή και ειδική επικόλληση από φύλλο σε φύλλο.
Αποφεύγω τη χρήση αντικειμένων του VBProject διότι είναι μια δύστροπη βιβλιοθήκη
και εμπλέκονται θέματα ρυθμίσεων ασφαλείας που πολλές φορές μας οδηγούν σε σοβαρά προβλήματα.

Τα νέα βιβλία αποθηκεύονται στην ίδια διαδρομή με το "CreateClearBook.xls".
Εξέτασε τον κώδικα της διαδικασίας "CreateClearBook()" και αν σε βολεύει,
τροποποίησέ τον στα μέτρα σου.

Τα λέμε!
Γιάννης

[Lokos]

Γιάννη καλημέρα και σ ευχαριστώ πολύ για το παράδειγμα σου!

Μου ήταν σχετικά εύκολο να το προσαρμόσω στα μέτρα μου τον μετρητή και τη διαδρομή,
ωστόσο το πρόβλημα που δημιουργείται είναι ότι η λίστα αρχείων που δημιουργείται μέσα στο αρχείο δεν μπορεί να είναι η πραγματική αφού στο συγκεκριμένο φάκελο αποθήκευσης θα αποθηκεύονται και άλλα αρχεία με την μορφή 001_Όνομα αρχείου.xls, 002_Όνομα αρχείου.xls κοκ. από άλλους συναδέλφους.
Έτσι αν ήδη υπάρχει το 002... αποθηκευμένο και το πρόγραμμα προτείνει το 002... θα πρέπει ή να αντικατασταθεί το ήδη υπάρχον, ή να ακυρώσω τη διαδικασία.

Σκέφτηκα λοιπόν να δημιουργήσω κάποιο κώδικα που να βρίσκει το αρχείο με το μεγαλύτερο πρόθεμα και συμφωνα μ αυτό να δημιουργεί το καινούργιο.

Δηλ. Αν το μεγαλύτερο πρόθεμα είναι το 008.. τότε να δημιουργηθεί το 009...

Πάνω σ αυτό θα ήθελα και πάλι τα φώτα σας.
Ευχαριστώ και πάλι

Γιώργος

[Tasos]

Φίλε Γιώργο καλησπέρα!

Παραλίγο να σε ξεχάσουμε!
O Γιάννης (nisgia) κι εγώ, καταλήξαμε στις παρακάτω λύσεις για το ζητούμενο σου.

Λύση 1:

Function GetNewFilePrefix(ByVal strPath As String) As String
    Dim objFiles As Object
    Dim objFile As Object
    Dim strTemp As String
    Dim intMax As Integer

    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(strPath) Then
            Set objFiles = .GetFolder(strPath).Files
            For Each objFile In objFiles
                strTemp = objFile
                If objFile.Type = "Microsoft Excel Worksheet" Then
                    strTemp = Mid(.GetFileName(strTemp), 1, 4)
                    If strTemp Like "###_" Then
                        If CInt(Left(strTemp, 3)) > intMax Then
                            intMax = CInt(Left(strTemp, 3))
                        End If
                    End If
                End If
            Next objFile
        Else
            MsgBox "Invalid Path!", vbExclamation
        End If
    End With
    GetNewFilePrefix = Format(intMax + 1, "000_")
End Function

Λύση 2:

Function NextFreeName(strPath$, strFile$) As String
    Dim strEnum%, sFile$
    strPath = strPath & IIf(Right(strPath, 1) <> "\", "\", "")
    sFile = Dir(strPath & "*" & strFile, vbNormal)
    Do Until sFile = ""
        strEnum = Application.Max(strEnum, IIf(IsNumeric(Left(sFile, 3)), Left(sFile, 3), 0))
        sFile = Dir
    Loop
    NextFreeName = strPath & IIf(strEnum = 0, "001_", _
            Format(strEnum + 1, "000_")) & strFile
End Function

Δες και το συνημμένο παράδειγμά (με τη δεύτερη λύση).

Ελπίζω να σε καλύψαμε!

Φιλικά

Τάσος

[Lokos]

Καλημέρα!

Γιάννη , Τάσο, σας ευχαριστώ πάρα μα πάρα πολύ για τον χρόνο σας!

Προσάρμοσα τους κώδικες και όλα είναι μια χαρά!

Να είστε όλοι καλά!

[Flashgordon61]

Καλησπέρα σε όλους

Τα ζητούμενα 3.
1) Πως μπορεί η καταγραφή να μην γίνεται στο τρέχον φύλλο εργασίας (Data) αλλά σε ένα άλλο φύλλο εργασίας (Backup) προσθέτοντας δεδομένα σε άλλες 2 στήλες
(“B” & “C) που θα τα παίρνει από την περιοχή (Date) (Το πρώτο και το τελευταίο μη κενό κελί).
2) Πως μπορεί η καταγραφή της διαδρομής του αρχείου να είναι τέτοια ώστε να δημιουργεί υπερσύνδεση (Hyperlink) .
Με κλικ να ανοίγει το αρχείο
3) Αν σβήσουμε τα δεδομένα από την περιοχή με όνομα (Data) το ζητούμενο είναι ένας κώδικας που να κάνει επαναφορά των δεδομένων (Reset) από το τελευταίο
αποθηκευμένο αρχείο.

(Σημείωση : Στο επισυναπτόμενο αρχείο έχω προσθέσει στο κώδικα το
Range("A3:C30").Select
ActiveWorkbook.Names.Add Name:="Data", RefersToR1C1:="=Sheet1!R3C1:R30C3"
που δημιουργεί και στο αρχείο εξαγωγής μια περιοχή με όνομα (Data) επειδή πιστεύω ότι αυτό εξυπηρετεί το 3ο ζητούμενο.)

Περιμένοντας τη βοήθειά σας
Σας ευχαριστώ εκ των προτέρων

Φιλικά
Γιώργος