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

**أبوبسمله** · يناير 22, 2016

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

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

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

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

تجزئه.rar

ياسر خليل أبو البراء · يناير 23, 2016

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

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

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

**أبوبسمله** · يناير 23, 2016

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

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

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

**رجب جاويش** · يناير 23, 2016

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

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

تفضل أخى

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

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

**أبوبسمله** · يناير 23, 2016

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

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

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

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

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

**رجب جاويش** · يناير 23, 2016

عذرا أخى

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

تفضل

تجزئه3.rar

**أبوبسمله** · يناير 23, 2016

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

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

**رجب جاويش** · يناير 23, 2016

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

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

**أبوبسمله** · يناير 23, 2016

اخى رجب

لى استفسار

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

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

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

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

ياسر خليل أبو البراء · يناير 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

**أبوبسمله** · يناير 23, 2016

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

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

**رجب جاويش** · يناير 23, 2016

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

أحسنت وأبدعت

مهند الزيدي · يناير 23, 2016

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

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

ياسر خليل أبو البراء · يناير 24, 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

تقبل تحياتي

مهند الزيدي · يناير 24, 2016

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

ياسر خليل أبو البراء · يناير 24, 2016

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

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

**أبوبسمله** · يناير 24, 2016

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

بالتوفيق

مهند الزيدي · يناير 24, 2016

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

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

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

ياسر خليل أبو البراء · يناير 25, 2016

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

الدالة 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 يتم تنفيذ الأسطر التالية ...

**أبوبسمله** · يناير 25, 2016

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

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

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

ولى سؤال هنا

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

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

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

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

**أبوبسمله** · يناير 25, 2016

للرفع

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

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

مهند الزيدي · يناير 25, 2016

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

ياسر خليل أبو البراء · يناير 25, 2016

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

تقبل تحياتي

**أبوبسمله** · يناير 25, 2016

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

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

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

تسجيل الدخول

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

الردود الموصى بها

أبوبسمله

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

أبوبسمله

رجب جاويش

أبوبسمله

رجب جاويش

أبوبسمله

رجب جاويش

أبوبسمله

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

أبوبسمله

رجب جاويش

مهند الزيدي

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

مهند الزيدي

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

أبوبسمله

مهند الزيدي

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

أبوبسمله

أبوبسمله

مهند الزيدي

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

أبوبسمله

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information