[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

Τάσος