فتح شيت جديد حسب تاريخ اليوم في التبويب

[سموالشوق]

السلام عليكم

 

اخواني هل ممكن تساعدوني في هذا الطلب وللتوضيح اكثر

داخل الملف المرفق لكم

07-06-2015.rar

[ياسر خليل أبو البراء]

أخي الكريم سمو الشرق

إليك الكود التالي فيه المطلوب بإذن الله

Sub CreateSheetAsCopyFromtemp()

    Dim WS As Worksheet: Set WS = Sheet1
    Dim LR As Long: LR = WS.Cells(Rows.Count, "I").End(xlUp).Row + 1
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        If blnWorksheetExists(Format(Date, "yyyy-mm-dd")) Then
            MsgBox "ورقة العمل موجودة من قبل", vbInformation: Exit Sub
        Else
            With Sheets("Temp")
                .Visible = True
                    .Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Format(Date, "yyyy-mm-dd")
                    With WS
                        .Range("H" & LR).Value = .Range("H" & LR).Row - 4
                        .Range("I" & LR).Value = ActiveSheet.Name
                        .Range("I" & LR).NumberFormat = "yyyy-mm-dd"
                        .Hyperlinks.Add Anchor:=.Range("I" & LR), Address:="", SubAddress:="'" & Sheets(.Range("I" & LR).Text).Name & "'" & "!A1"
                    End With
                .Visible = False
            End With
        End If
        WS.Activate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Function blnWorksheetExists(strWorksheet As String) As Boolean

    On Error Resume Next
    blnWorksheetExists = Not (ThisWorkbook.Worksheets(strWorksheet) Is Nothing)
    On Error GoTo 0
    
End Function

تم تعديل بسيط في ورقة العمل "الواجهة" لالغاء دمج الخلايا ، وتم إدراج صف مخفي ليناسب عمل الكود ..

إذا أعجبتك الإجابة يرجى تحديد كأفضل إجابة ، ولا تنسى أن تضغط على كلمة "أعجبني هذا"

تقبل تحياتي

Create Sheet As Copy From Temp & Rename It By Date.rar

[ابو محمد نصري]

ماشاء الله دائما مبدع استاذ ياسر

[محمد الريفى]

ماشاء الله عليك يااستاذ ياسر

ولكن لدى ملاحظه بسيطة

الحد الاقصى لعدد الشيتات حتى 255 شيت

وعدد ايام السنه حوالى من 300 يوم عملى الى 365

فماذا لو تجاوز التاريخ الحد الاقصى لعدد الشيتات ؟.

تقبلوا تحياتى

[ياسر خليل أبو البراء]

أخي الغالي محمد الريفي

أنا مش هرد عليك ..الملف المرفق هو اللي هيرد ..قم بالإطلاع على عدد الأوراق في المصنف وجرب تضيف أوراق أخرى

Test.rar

[محمد الريفى]

اولا:: جزاكم الله خيرا .. اضافه الى معلومه لم اكن اعرفها

ثانيا: ماسبب  هذه الرساله التى تخبرنا بان المصنف لايقبل اكثر من 255 ورقة عمل ؟

[ياسر خليل أبو البراء]

أخي الحبيب محمد

هذا الخيار لاختيار عدد أوراق البداية لما تيجي تنشيء مصنف جديد ..لكن العدد ممكن يزيد عن 255

أما بالنسبة للخيار ده فآخره 255

أرجو أن تكون الأمور واضحة الآن

[محمد حسن المحمد]

أخي الغالي محمد الريفي

أنا مش هرد عليك ..الملف المرفق هو اللي هيرد ..قم بالإطلاع على عدد الأوراق في المصنف وجرب تضيف أوراق أخرى

السلام عليكم ورحمة الله وبركاته

لولا أن يحدد العدد الأقصى من الأوراق من قبل مصممي برنامج إكسل...لوصلنا إلى ما لا تهاية من الأوراق.

متى سيتم استخدامها كاملة؟ ...هل سيشهد عالمنا المعاصر أم أننا سنتركها للأجيال اللاحقة من البشر.

[سموالشوق]

أخي الكريم سمو الشرق

إليك الكود التالي فيه المطلوب بإذن الله

Sub CreateSheetAsCopyFromtemp()

    Dim WS As Worksheet: Set WS = Sheet1
    Dim LR As Long: LR = WS.Cells(Rows.Count, "I").End(xlUp).Row + 1
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        If blnWorksheetExists(Format(Date, "yyyy-mm-dd")) Then
            MsgBox "ورقة العمل موجودة من قبل", vbInformation: Exit Sub
        Else
            With Sheets("Temp")
                .Visible = True
                    .Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Format(Date, "yyyy-mm-dd")
                    With WS
                        .Range("H" & LR).Value = .Range("H" & LR).Row - 4
                        .Range("I" & LR).Value = ActiveSheet.Name
                        .Range("I" & LR).NumberFormat = "yyyy-mm-dd"
                        .Hyperlinks.Add Anchor:=.Range("I" & LR), Address:="", SubAddress:="'" & Sheets(.Range("I" & LR).Text).Name & "'" & "!A1"
                    End With
                .Visible = False
            End With
        End If
        WS.Activate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Function blnWorksheetExists(strWorksheet As String) As Boolean

    On Error Resume Next
    blnWorksheetExists = Not (ThisWorkbook.Worksheets(strWorksheet) Is Nothing)
    On Error GoTo 0
    
End Function

تم تعديل بسيط في ورقة العمل "الواجهة" لالغاء دمج الخلايا ، وتم إدراج صف مخفي ليناسب عمل الكود ..

إذا أعجبتك الإجابة يرجى تحديد كأفضل إجابة ، ولا تنسى أن تضغط على كلمة "أعجبني هذا"

تقبل تحياتي

 

 

الاستاذ /  ياســر

 

شكـــرا وجزاك الله خير

[سموالشوق]

استاذ ياسر

 

هل من الممكن وضع كود عدم حذف اي معادلة بصفحة وعند ادراج صفحة جديدة يكون الكود هذا فية ..؟

 

واسف علي الطلب الثاني

[صلاح الصغير]