كود اضافة ورقة بتسمية جديدة

[منيير]

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

في الملف اسفله لدي كود ربطته بالزر المسمى Add A New Sheet يقوم باضافة ورقة جديدة بنفس مقاييس الورقة القديمة كما يقوم بمسح النطاق B9:J39 مع المحافظة على المعادلات 

المشكل يا اخواني في الكود هو عندما اضغط على زر  Add A New Sheet ياخد وقت كثير لعمل Copy 

هل ممكن تعديل الكود بارك الله فيكم ؟؟؟؟

Suivi Béton - Copie.zip

[منيير]

مساعدة بارك الله فيكم

[منيير]

مساعدة بارك الله فيكم

[منيير]

تفضل اخي ابو عبيد

Suivi Béton - Copie.zip

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

أخي الفاضل منير

لربما لو أوضحت طلبك بشيء من التفصيل لكان أفضل

ما هو الورقة التي يتم نسخها ؟ وهل تريد مس القيم الثابتة والإبقاء على المعادلات فقط ؟ يرجى توضيح المطلوب بشكل تفصيلي وليس بشكل عام ..يعني ايه الورقة المطلوب العمل عليها !!؟

[منيير]

اخي العزيز ياسر ما اريده هو تعديل الكود الموجود في الموديل المسمى NewMonthSheet والذي يقوم بنسخ الورقةJuillet-2013 و يبقي على جميع المعادلات و الورقة المنسخة تحافظ على المعادلات و اسمها يتغير لياخد اسم الشهر الموالي للشهر المسمى في الروقة السابقة

المشكل اخي ياسر في الكود هو انه يقوم بكل هذا و لكنه ثقيل ياخد وقت قبل ان يقوم بالعملية 

 

Suivi Béton - Copie.zip

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

جرب الكود بهذا الشكل

Sub NewMonth_Sheet()
    Dim lSht As Worksheet
    Dim nSht As Worksheet
    Dim shName As String
    
    Set lSht = Sheets(Sheets.Count)
    
    If IsDate(lSht.Name) Then
    
    shName = Application.Proper(Format(DateAdd("m", 1, lSht.Name), "mmmm-yyyy"))
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        On Error Resume Next 'Tests that sheet doesn't already exist
        Set nSht = Sheets(shName)
        On Error GoTo 0
        
        If nSht Is Nothing Then
        lSht.Copy after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = shName
        Else
        MsgBox "Sheet """ & shName & """ already exists!", vbCritical
        End If
        Else
        MsgBox "Last sheet name does not" & Chr(10) & "represent a month!", vbCritical: Exit Sub
        End If
        For Each ce In [B9:J39]
                If ce.HasFormula = True Then GoTo 10
            ce.ClearContents
10         Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

[منيير]

شكرا كثيرا اخي ياسر خليل الكود يعمل جيدا

 بارك الله فيك في هذه الجمعة المباركة لك و لكل الاخوة الساهرين على الرقي بهذا المنتدى الى الامام

شكرا مرة اخرى