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

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Αποθήκευση και αρίθμηση αρχείων (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/431-apothikeysi-kai-arithmisi-arxeion.html)

Lokos

19-02-10 08:39

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

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

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

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

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

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

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

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

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

Γιώργος

nisgia

19-02-10 19:40

1 Συνημμένο(α)

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

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

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

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

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

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

Lokos

20-02-10 11:41

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

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

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

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

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

Γιώργος

Tasos

25-02-10 18:08

1 Συνημμένο(α)

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

Παραλίγο να σε ξεχάσουμε!
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

26-02-10 00:24

Καλημέρα!

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

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

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

Flashgordon61

24-03-11 02:17

1 Συνημμένο(α)

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

Τα ζητούμενα 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ο ζητούμενο.)

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

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

Η ώρα είναι 12:53.

Search Engine Optimization by vBSEO 3.3.2