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/1775-aytomati-dimioyrgia-kai-onomasia-fillon.html)

Καλησπέρα στην παρέα

Λευτέρη το αρχείο που επισυνάπτω αποτελεί μια τροποποιημένη έκδοση της λύσης που πρότεινε ο Σπύρος.

Ονομάζεται «AddSheetstoWbFinal2.xls» και περιέχει μόνο ένα φύλλο το «ADD_SHEETS», που είναι σχεδόν ίδιο με αυτό που πρότεινε ο Σπύρος.

Το φύλλο αυτό περιέχει τον αναγκαίο κώδικα VBA για την προσθήκη φύλλων στο βιβλίο ίδιων με κάποιο υπάρχον (ΕΠΙΛΟΓΕΣ).

Για να μπορέσεις να το χρησιμοποιήσεις θα πρέπει να το μεταφέρεις στο βιβλίο που έχεις τα φύλλα «ΚΕΝΤΡΙΚΟ», «ΕΠΙΛΟΓΕΣ» και οποιαδήποτε άλλα, εκτός αυτών που θα προσθέτονται αυτόματα.

Αν υποθέσουμε ότι το βιβλίο σου ονομάζεται «ΛΕΥΤΕΡΗΣ.xls» η μεταφορά του φύλλου μπορεί να γίνει, με τα ακόλουθα βήματα:

1) Ανοίγουμε και τα δύο βιβλία (ΛΕΥΤΕΡΗΣ.xls, AddSheetstoWbFinal2.xls).

2) Με ενεργό το AddSheetstoWbFinal2.xls κάνουμε δεξί κλικ στην καρτέλα (Tab) του φύλλου «ADD_SHEETS» και κλικ στην επιλογή «Μετακίνηση ή Αντιγραφή» του μενού συντόμευσης.

3) Στο πλαίσιο διαλόγου επιλέγουμε το βιβλίο «ΛΕΥΤΕΡΗΣ.xls» και το φύλλο του πριν από το οποίο θα μετακινηθεί (αντιγραφεί) το «ADD_SHEETS» και τσεκάρουμε και το πλαίσιο «Δημιουργία αντιγράφου».

4) Κάνουμε κλικ στο OK όσες φορές χρειαστεί για να κλείσουν τα πλαίσια διαλόγου.

5) Αποθηκεύουμε το αρχείο «ΛΕΥΤΕΡΗΣ.xls», που περιέχει και το φύλλο «ADD_SHEETS».

Μετά την προσθήκη του φύλλου «ADD_SHEETS» στο βιβλίο «ΛΕΥΤΕΡΗΣ.xls» όλη η εργασία θα γίνεται από αυτό.

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

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

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

Καλησπέρα.

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

Αυτός είναι και ο λόγος που συνεχίζω το θέμα.

Αισθάνομαι ομολογουμένως, όμως, φοβερά άβολα.

Γιώργο, σωστά κατάλαβες το ζητούμενο. Αυτό είναι.

Δημιούργησα, ένα μικρό δείγμα, αυτού που θέλω και το επισυνάπτω.

Το μήνυμα, λάθους, που μου βγαίνει, λέει.

Παράθεση:

Σφάλμα εκτέλεσης "1004"

Η μέθοδος, "Indercect", του αντικειμένου "-Global" απέτυχε.

Τι κάνω, λάθος;;

Καλησπέρα

Λευτέρη πιστεύω ότι όλοι θέλουμε να βρεθεί λύση στο πρόβλημα, οπότε δεν υπάρχει λόγος να αισθάνεσαι άβολα.

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

Μετέφερα τα φύλλα για τα οποία ενδιαφέρεσαι στο αρχείο που περιέχει το φύλλο «ADD_SHEETS» και ονόμασα το νέο αρχείο «ΛΕΥΤΕΡΗΣ3.xls».

Είναι το αρχείο που επισυνάπτω.

Το αρχείο αυτό λειτουργεί κανονικά στον υπολογιστή μου.

Θα πρέπει να το δοκιμάσεις και στο δικό σου.

Πάντως στο φύλλο «Δείγμα», που θέλεις να αντιγράφεται δεν είδα τύπους.
Έτσι και αν ακόμα το αρχείο λειτουργεί στον υπολογιστή σου, μάλλον δε θα σου είναι χρήσιμο.

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

Γιώργο, πιθανά να υπάρχει πρόβλημα στον υπολογιστή μου.

Θα το τσεκάρω και αύριο το πρωί στη δουλειά.

Το αρχείο που μου έστειλες(το τελευταίο),ανοίγει κανονικα και δουλεύει, κανονικά.

Η σειρά μόνο, θέλω να είναι διαφορετική.

Δηλαδή, τα νέα φύλλα, να μπαίνουν μεταξύ του φύλλου Start και End και το Δείγμα στο τέλος(Μετά το End)

Βέβαια, πάνω από όλα είναι να καταφέρω στον υπολογιστή μου, να δημιουργήσω τα φύλλα μου, όπως μου περιέγραψες στο προηγούμενο Post σου.

Ευχαριστώ πολύ..

Καλημέρα
Αλλάζοντας κάτι ( τον τρόπο αντιγραφής) στον κώδικα του Γιώργου τώρα έχεις το ζητούμενο
Τα φύλλα που προστίθενται είναι αντίγραφα του "Δείγμα"
με ονομασία των ημερών που επιλέγεις
Και προστίθενται ανάμεσα στα "Start" & "End"
To Original "Δείγμα" παραμένει στο Τέλος.
Χρωμάτισα την ετικέτα του "Δείγμα" για να φανεί καλύτερα
Αν θες την αλλάζεις
Σημείωση
Τα αντεγραμμένα φύλλα έχουν όλες τις ιδιότητες του Original
που σημαίνει ότι ακόμα και το χρώμα τις ετικέτας του φύλλου θα αντιγραφεί
ΥΓ Ο κώδικας είναι πλέον σε Module και οχι στο Φύλλο

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

Σπύρο, άνοιξα το συνημμένο σου και δουλεύει ακριβώς:thumbup1: όπως ζήτησα.

Θα το τοποθετήσω και θα το τρέξω,στο κανονικό βιβλίο μου και θα σας ενημερώσω, οπωσδήποτε.

Ευχαριστώ πολύ και εσένα και τον Γιώργο, για την υπομονή σας, τον χρόνο και τον κόπο σας.

Ευχαριστώ φυσικά και τον Φίλο μου τον Τάσο, για τις προτάσεις του, που μακάρι να ήμουν ικανός να μπορούσα να τις "ανοίξω" και φυσικά να τις καταλάβω.

Καλημέρα Λευτέρη!

Η πρόταση μου δεν διαφέρει και πολύ από τις προτάσεις του Σπύρου και του Γιώργου ως προς το αποτέλεσμα.

Απλά δεν χρειάζεται να ενσωματωθεί σε βιβλίο Excel και μπορεί να χρησιμοποιηθεί για όποιο βιβλίο θελήσει κανείς.

Θα το κάνω όσο μπορώ πιο απλό για όποιον θελήσει κάτι αντίστοιχο περιγράφοντας τα βήματα δημιουργίας αυτής της πρότασης:

Ανοίγουμε ένα σημειωματάριο ( Notepad ) και επικολλούμε τον κώδικα που υπάρχει στο τέλος του μηνύματος.
Για να αποθηκευτεί το έγγραφο κειμένου με την κατάληξη *.vbs, επιλέγουμε το μενού Αρχείο>Αποθήκευση ως...
Στο διάλογο που θα εμφανιστεί κάνουμε τις ρυθμίσεις όπως φαίνονται στην εικόνα παρακάτω:

Συνημμένο Αρχείο 2901

Εκτελούμε το αποθηκευμένο αρχείο με διπλό κλικ.

Κατά τη ροή του προγράμματος θα μας ζητηθούν τα παρακάτω:

Επιλογή αρχείου Excel στο οποίο θα αντιγραφούν αυτόματα τα φύλλα
Επιλογή του πρότυπου φύλλου προς αντιγραφή
Επιλογή του μήνα και του έτους

Τα πρότυπο φύλλο αντιγράφεται τόσες φορές όσες οι μέρες του μήνα που θα επιλέξουμε ( Εκτός τις Κυριακές ).

Κώδικας:

Option Explicit
 

Const ErrNoExcelInstalled = 429

Dim XL

Dim XlFileName

Dim WksFunc

Dim wb

Dim sh

Dim wks

Dim wksTemplateName

Dim TheMonth

Dim TheYear

Dim StartDate

Dim EndDate

Dim strDate

Dim i

Dim x

Dim UserResponse

Dim oShell
 

Function GoToExit()

        XL.ScreenUpdating = True

        XL.Quit

        Set XL = Nothing

        WScript.Quit

End Function
 

Function SetTheMonth()

    UserResponse = XL.InputBox("Συμπληρώστε το μήνα", "Εισαγωγή μήνα...", , , , , , 1)

    If VarType(UserResponse) = 11 Then

        GoToExit

    ElseIf UserResponse < 1 Or UserResponse > 12 Then

        MsgBox "Συμπληρώστε ένα μήνα ανάμεσα στο 1 και 12 για να συνεχίσετε", 64, "ms-office.gr"

        SetTheMonth

    End If

    SetTheMonth = UserResponse

End Function
 

Function SetTheYear()

    UserResponse = XL.InputBox("Συμπληρώστε το έτος", "Εισαγωγή έτους...", , , , , , 1)

    If VarType(UserResponse) = 11 Then

        GoToExit

    ElseIf UserResponse < 1900 Or UserResponse > 2099 Then

        MsgBox "Συμπληρώστε ένα έτος ανάμεσα στο 1900 και 2099 για να συνεχίσετε", 64, "ms-office.gr"

        SetTheYear

    End If

    SetTheYear = UserResponse

End Function
 

Function ThisWorksheetExists()

    ThisWorksheetExists = false

    For Each sh In wb.Sheets

        If sh.Name = strDate Then

            ThisWorksheetExists = True

            Exit function

        End If

    Next

End Function

On Error Resume Next

Set XL = CreateObject("Excel.Application")
 

If Err.Number  = ErrNoExcelInstalled Then

    MsgBox  "Δεν βρέθηκε εγκατεστημένη έκδοση Microsoft Excel στο σύστημα σας!", 48, "ms-office.gr"

    WScript.Quit

End If

 

On Error Goto 0
 

XlFileName = XL _

        .GetOpenFilename("Αρχεία Excel (*.xls), *.xls", 0, "Επιλέξτε το αρχείο όπου θα αντιγραφούν τα φύλλα...")

If XlFileName = False Then

    GoToExit

End If
 

Set wb = XL.Workbooks.Open(XlFileName)

XL.WindowState = -4137

XL.Visible = True
 

Set oShell = CreateObject("Wscript.Shell")
 

x = oShell.AppActivate(XL.Caption)
 

On Error Resume Next
 

Set UserResponse = XL.InputBox( _

"Επιλέξετε το πρότυπο φύλλο προς αντιγραφή και κάντε κλικ σε ένα κελί.", "Επιλογή πρότυπου φύλλου...", , , , , , 8)
 

If UserResponse Is Nothing Then

    GoToExit

Else

    wksTemplateName = UserResponse.Parent.Name

End If
 

On Error Goto 0
 

WScript.Sleep 200
 

TheMonth = SetTheMonth

WScript.Sleep 200

TheYear = SetTheYear
 

StartDate = DateSerial(TheYear, TheMonth, 1)

EndDate = DateSerial(TheYear, TheMonth + 1, 0)
 

Set WksFunc = XL.WorksheetFunction

XL.ScreenUpdating = False

XL.Calculation = -4135

For i = StartDate To EndDate

    If WksFunc.Weekday(i, 2) < 7 Then

           strDate = WksFunc.Text(i, "[$-408]ddd dd-mm-yy")

        If Not ThisWorksheetExists Then

            wb.Worksheets(wksTemplateName).Copy , wb.Sheets(wb.Sheets.Count) 'XL.ActiveSheet

            Set wks = XL.ActiveSheet

            wks.Name = strDate

        End If

    End If

Next

XL.Calculation = -4105

XL.ScreenUpdating = True

WScript.Quit

Τάσος