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/465-dimioyrgia-neoy-filloy.html)

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

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

Σε βιβλίο 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

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

Γιώργος

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

Ο 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

Φιλικά

Τάσος

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

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

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

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

Με εκτίμηση

Γιώργος.