[VBA] Δημιουργία νέου φύλλου

[Lokos]

Καλημέρα και συγχαρητήρια στο φόρουμ!

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

Δοκίμασα με macro recorder αλλά δεν λειτουργεί.

Μπορεί κάποιος να μου πεί τί θα πρέπει να άλλάξω στην ακόλουθη μακροεντολή
για να δουλεύει αποτελεσματικά;

Sub Macro4()
'
' Macro4 Macro
'

'
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet5").Select
Sheets("Sheet5").Name = "Week4"
Range("E3").Select
ActiveSheet.Buttons.Add(194.25, 30, 72, 72).Select
Selection.OnAction = "Macro4"
ActiveSheet.Shapes("Button 1").Select
Selection.Characters.Text = "CreateNewBook"
With Selection.Characters(Start:=1, Length:=15).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = 2
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.ShapeRange.ScaleWidth 1.88, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Range("A1").Select
End Sub

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

Γιώργος

[Tasos]

Γιώργο καλημέρα!

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

Function CurrWeekNum(d As Date) As Integer
    Dim xd#
    xd = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
    CurrWeekNum = (d - xd - 3 + (Weekday(xd) + 1) Mod 7) / 7 + 1
End Function

Για την προσθήκη φύλλου εργασίας όπως το ζήτησες μπορείς να χρησιμοποιήσεις
(αφού κάνεις τυχόν προσαρμογές) τον παρακάτω κώδικα:

Option Explicit

Sub CreateWorkSheetWithButton()
    Dim WeekNumber$, wks As Worksheet
    WeekNumber = "Week" & CurrWeekNum(Date)
    On Error Resume Next
    Set wks = ThisWorkbook.Worksheets(WeekNumber)
    If Not wks Is Nothing Then Exit Sub
    Err.Clear
    On Error GoTo 0
    With ThisWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
        .Name = WeekNumber
        With .Buttons.Add(1, 1, 1, 1)
            .Name = "Btn1"
            .Caption = "My Button"
            .Top = Range("E2").Top
            .Left = Range("E2").Left
            .Width = Range("E2").Width
            .Height = Range("E2").Height
            .OnAction = ThisWorkbook.Name & "!MyMacroName"
            With .Characters(1, Len(.Caption)).Font
                .Name = "Arial"
                .FontStyle = "Standard"
                .Size = 10
                .ColorIndex = 3
            End With
        End With
    End With
End Sub

Function CurrWeekNum(d As Date) As Integer
    Dim xd#
    xd = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
    CurrWeekNum = (d - xd - 3 + (Weekday(xd) + 1) Mod 7) / 7 + 1
End Function

Φιλικά

Τάσος

[Lokos]

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

Φίλε Τάσο, σ ευχαριστώ πολύ για τις συμβουλές και φυσικά για τον κώδικα!

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

Δεν ξέρω κατά πόσον το γνωρίζεις αλλά το φόρουμ αυτό, αν και καινούργιο, είναι αξεπέραστο σε ποιότητα!

Με εκτίμηση

Γιώργος.