كود انشاء صفحه مثل صفحه موجوده

[أبوبسمله]

السلام عليكم اخوانى الكرام 

اريد مساعدتكم فى انشاء كود لانشاء صفحه لكل مكتب من المكاتب المدرجه ويكون نسخه من النموذج المرفق وبجميع تنسيقاته وحماياته وان يتم كتابة اسم الشيت هو اسم المكتب على ان يقوم الكود عند تشغيله مره اخرى اذا كان قد تم انشاء المكاتب فلا يقوم بائنشائها مره اخرى ويضيف مالم يتم انشائه إن وجد ثم يقوم بعمل هايبر لينك بين اسم المكتب المدرج بالجدول والصفحه اللتى تم انشائها باسم المكتب

ارجو معذرتى على كثرة الطلبات والاطاله 

جزاكم الله خيراً

تجزئه.rar

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

أخي الكريم أحمد

يرجى عند إرفاق ملف أن تقوم بوضع كلمات السر لأوراق العمل والمصنف

حاولت البدء في حل مشكلتك ولكن ظهرت لي رسالة بأن المصنف محمي ..فما هي كلمة الحماية للمصنف؟

 

[أبوبسمله]

انا اسف اخى ياسر 

ما اخدتش بالى والله كلمة السر 123

جزاك الله كل خير

[رجب جاويش]

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

بعد اذن أخى الحبيب ياسر خليل

تفضل أخى

جرب الكود التالى

Sub ragab()
Dim cl As Range, sh As Worksheet
Dim ws As Worksheet
'=======================================
Set sh = Sheets("الرئيسيه")
Set ws = Sheets("النموذج")
'=======================================
Application.ScreenUpdating = False
ThisWorkbook.Unprotect "123"
ws.Unprotect "123"
'=======================================
For Each cl In sh.Range("D4:R7")
    If Not IsEmpty(cl) Then
        x = Trim(cl)
        On Error Resume Next
        If Worksheets(x) Is Nothing Then
            Sheets.Add.Name = x
            Sheets(x).Move After:=Sheets(Sheets.Count)
            ws.Range("A1:k36").Copy
             With Sheets(x)
                 .Select
                 .Paste
                 .Protect "123"
             End With
        End If
   End If
Next
'=======================================
Application.CutCopyMode = False
ThisWorkbook.Protect "123"
ws.Protect "123"
Sheets("الرئيسيه").Select
Application.ScreenUpdating = False
End Sub

 

تجزئه2.rar

[أبوبسمله]

جزاك الله كل خير اخى رجب 

فى جزئيه اخيره انه يتم عمل هايبر لينك بين كل اسم وصفحته 

واسف انى بتعبكم 

جزاكم الله كل خير اخوانى الكرام

13 دقائق مضت, رجب جاويش said:

 

[رجب جاويش]

عذرا أخى

فقد نسيت هذه النقطة

تفضل

 

تجزئه3.rar

[أبوبسمله]

لك العذر يا اخى الفاضل و شكرا لك 

جزاك الله كل خير اخى رجب 

 

[رجب جاويش]

وجزاك الله كل خير أخى أحمد

الحمد لله أن تم المطلوب

 

[أبوبسمله]

اخى رجب 

لى استفسار 

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

تمام لاقيت الخطا

جزاكم الله خيرا

تم تعديل يناير 23, 2016 بواسطه أحمد الفلاحجى

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

أخي الكريم أحمد

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

عموماً الحل قريب جداً من الحل المقدم من أخونا الغالي رجب ..فقط اختلاف بسيط ، وإليك الكود إثراءً للموضوع لا أكثر

Sub CreateSheets()
    Dim Cel As Range, strCel As String
    
    Application.ScreenUpdating = False
        ThisWorkbook.Unprotect 123
        Sheet2.Unprotect 123
        
            For Each Cel In Sheet1.Range("D4:R" & Sheet1.Cells(Rows.Count, 4).End(xlUp).Row)
                strCel = Trim(Cel.Value)
                If strCel <> "" Then
                    If Not Evaluate("ISREF('" & strCel & "'!A1)") Then
                        Sheet2.Copy After:=Sheets(Sheets.Count)
                        ActiveSheet.Name = strCel
                        
                        Cel.Hyperlinks.Add Cel, "", , "Screen_Tip", strCel
                        Cel.Hyperlinks(1).SubAddress = "'" & strCel & "'" & "!A1"
                        
                        ActiveSheet.Protect 123
                    End If
                End If
            Next Cel
            
        ThisWorkbook.Protect 123
        Sheet2.Protect 123
    Application.ScreenUpdating = True
    
    MsgBox "Done ...", 64
End Sub

تقبل تحياتي

Create Sheets By Cells In Range & Add Hyperlinks YasserKhalil.rar

[أبوبسمله]

ماتحرمش منك اخى العزيز 

وبارك الله فيكم وجزاكم عنا خير الجزاء 

 

[رجب جاويش]

ربنا يخليك أخى الحبيب / ياسر

أحسنت وأبدعت

[مهند الزيدي]

شكر للأخ العزيز .. ياسر خليل  والإخ الفاضل رجب جاويش ..

ممكن شرح الكود خطوة بخطوة

 

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

أخي الكريم مهند الزيدي

إليك شرح لأسطر الكود لعله يفيد الجميع ، والشرح مهدى لأخونا الحبيب الغالي محمد حسن بمناسبة رجوعه بعد غياب أيام

Sub CreateSheets()
    'تعريف المتغيرات
    Dim Cel As Range, strCel As String
    
    'إلغاء خاصية تحديث الشاشة لتسريع عمل الكود
    Application.ScreenUpdating = False
        'إزالة الحماية عن المصنف بكلمة السر المرفقة
        ThisWorkbook.Unprotect 123
        'إزالة الحماية عن ورقة العمل التي تمثل النموذج المراد نسخه
        Sheet2.Unprotect 123
            
            'حلقة تكرارية لكل الخلايا في النطاق المطلوب إنشاء أوراق عمل لكل خلية من خلاياه
            For Each Cel In Sheet1.Range("D4:R" & Sheet1.Cells(Rows.Count, 4).End(xlUp).Row)
                'إزالة المسافات الزائدة من الخلية
                strCel = Trim(Cel.Value)
                
                'إذا لم تكن الخلية فارغة يتم تنفيذ الأسطر التالية أما إذا كانت فارغة يتم الانتقال للخلية التالية
                If strCel <> "" Then
                    'شرط لاختبار وجود ورقة العمل من عدم وجودها ، فإذا لم تكن ورقة العمل موجودة من قبل يتم تنفيذ التالي
                    If Not Evaluate("ISREF('" & strCel & "'!A1)") Then
                        'نسخ ورقة العمل النموذج في نهاية المصنف
                        Sheet2.Copy After:=Sheets(Sheets.Count)
                        'تسمية ورقة العمل التي تم نسخها باسم الخلية التي عليها العمل في الحلقة
                        ActiveSheet.Name = strCel
                        
                        'إنشاء ارتباط تشعبي للخلية لربطها بالورقة التي تم إنشائها
                        Cel.Hyperlinks.Add Cel, "", , "Screen_Tip", strCel
                        Cel.Hyperlinks(1).SubAddress = "'" & strCel & "'" & "!A1"
                        
                        'حماية ورقة العمل الجديدة التي تم نسخها
                        ActiveSheet.Protect 123
                    End If
                End If
            Next Cel
        
        'إرجاع الحماية للمصنف
        ThisWorkbook.Protect 123
        'إرجاع الحماية لورقة العمل النموذج
        Sheet2.Protect 123
        
    'إعادة تفعيل خاصية تحديث الشاشة
    Application.ScreenUpdating = True
    
    'رسالة تفيد بانتهاء عمل الكود كنوع من التنبيه لا أكثر
    MsgBox "Done ...", 64
End Sub

تقبل تحياتي

 

[مهند الزيدي]

شكرا الك أخي العزيز .. ياسر خليل ... وفقكم الله لكل خير

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

أخي الكريم مهند

كلمة "جزاكم الله خيراً" وقعها في نفسي وأجرها أفضل من كلمة الشكر .. إحنا من الآخر عايزين حسنات ودعوات (أفيضوا علينا بدعواتكم المباركة علها تكون لنا شفيعاً يوم البعث)

[أبوبسمله]

جزاك الله كل خيرا اخى ياسر على هذا الشرح الاكثر رائع 

بالتوفيق

[مهند الزيدي]

شكرا جزيلا لك اخي ياسر...

If Not Evaluate("ISREF('" & strCel & "'!A1)") Then

ماذا تعني ( " ( A1!'"  )

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

أخي الكريم مهند

الدالة ISREF ترجع القيمة True في حالة أن ورقة العمل موجودة وتعطي القيمة False إذا لم تكن موجودة والخلية A1 هي أول مرجع في ورقة العمل المراد التأكد من وجودها أو عدم وجودها

مثال لتفهم عمل الدالة : قم بإنشاء مصنف جديد وتأكد من وجود ورقة العمل Sheet1 بها وجرب الكود التالي

Sub CheckSheetExistence()
    MsgBox Evaluate("ISREF(Sheet1!A1)")
    MsgBox Evaluate("ISREF(Data!A1)")
End Sub

النتائج ستكون للسطر الأول True لأن الورقة موجودة والسطر الثاني False لأن ورقة العمل Data غير موجودة ...

بالتالي لو رجعنا للكود الأصلي سنجد أننا استخدمنا كلمة Not لعكس النتيجة ..بمعنى أن السطر في الكود الأصلي يفحص ويتأكد من عدم وجودة ورقة العمل فإذا لم (لاحظ لم Not) موجودة يتم تنفيذ باقي الأسطر ..أو بمعنى آخر : لو الورقة مش موجودة هتكون نتيجة الدالة False ووضعنا Not قبلها فيتم تحويل القيمة من False إلى True ، بالتالي طالما أن القيمة ستكون True يتم تنفيذ الأسطر التالية ...

[أبوبسمله]

جزاك الله كل خير اخى ياسر على سعة صدرك 

وزادك الله من فضله وعلمه 

بالتوفيق اخى واخوانى الافاضل 

 

ولى سؤال هنا 

قبل انشاء موضوع جديد 

هل من الممكن وضع كود يسمح بالكتابه على هذا العمل على الشبكه لانى جربت بالعمل بالامس ولم يسمح لى الا بالقرائه فقط 

فان لم يكن سوف اقوم بتغيير التصميم بموضوع جديد 

جزاكم الله عنا خير الجزاء

[أبوبسمله]

للرفع

ولا استعجل عليكم ولكنها للتذكير فقط

بالتوفيق اخوانى الافاضل

[مهند الزيدي]

اخي العزيز ياسر خليل وفقك الله لكل خير .. وجعله في ميزان حسناتك ..ورزقك الصحة والعافية

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

أرى أنه من الأفضل طرح موضوع جديد ليطلع عليه جل الأعضاء ويدلي كل من له خبرة بدلوه ...

تقبل تحياتي

[أبوبسمله]

حاضر يا اخى الغالى 

ساقوم بفتح موضع جديد له ان شاء الله تعالى 

جزاك الله خيرا