[VBA] Αυτόματη δημιουργία και ονομασία φύλλων.

[kapetang]

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

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

Ονομάζεται «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" απέτυχε.

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

[kapetang]

Καλησπέρα

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

[Spirosgr]

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

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

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

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

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

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

[Tasos]

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

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

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

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

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

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

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

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

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

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

Τάσος