كود اضافة شيت جديد باسم يحدده المستخدم

[اسلام سيد]

السلام عليكم

 

هذا كود لاضافة شيت جديد وجده على اليوتيوب من ضمن سلسله تعلم اون لاين

 

والمطلوب : هو عدم اضافه شيت مكرر

 

حيث يقوم فى حاله اضافة اسم مكرر باضافه شيت جديد بدون اسم

 

اضافة شيت جديد1.rar

 

 

[احمد عبد الناصر]

السلام عليكم

 

جرب هذا 

Sub newsheetcustomename()

Dim sheetname As String

sheetname = InputBox("ãä ÝÖáß ÇÏÎá ÇÓã ÇáÔíÊ")

If sheetname = "" Or Len(sheetname) > 31 Then
MsgBox ("ÇäÊ áã ÊÏÎá ÇáÇÓã Çæ ÇÓã ÇáÔíÊ ÇßÈÑ ãä 31 ÍÑÝ")

Exit Sub

End If

For Each s In ActiveWorkbook.Sheets
If s.Name = sheetname Then
Sheets.Add
Exit Sub
End If
Next
Sheets.Add.Name = sheetname

End Sub

او هذا 

Sub newsheetcustomename()

Dim sheetname As String

sheetname = InputBox("ãä ÝÖáß ÇÏÎá ÇÓã ÇáÔíÊ")

If sheetname = "" Or Len(sheetname) > 31 Then
MsgBox ("ÇäÊ áã ÊÏÎá ÇáÇÓã Çæ ÇÓã ÇáÔíÊ ÇßÈÑ ãä 31 ÍÑÝ")

Exit Sub

End If

On Error Resume Next
Sheets.Add.Name = sheetname

End Sub

تحياتي

[اسلام سيد]

السلام عليكم

استاذ / احمد عبد الناصر

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

للاسف الكود الاول والثانى (لايعمل معى)

تم تعديل أبريل 25, 2013 بواسطه إسلام الشيمي

[حمادة عمر]

السلام عليكم

الاخ الحبيب / إسلام الشيمي

 

بارك الله فيك

الكود المرسل من الاخ الحبيب / احمد عبد الناصر .... جزاه الله خيرا

يعمل بكفاءة ودقه عاليه ... وبعد اذنه

لكن عليك بعد لصق الكود في المودل ... ان تقوم بتغيير الحروف الغير مفهومة بين الاقواس في اسطر الرسائل

الاسطر التاليه ... مثلا في الكود الثاني

sheetname = InputBox("ãä ÝÖáß ÇÏÎá ÇÓã ÇáÔíÊ")

وكذلك

MsgBox ("ÇäÊ áã ÊÏÎá ÇáÇÓã Çæ ÇÓã ÇáÔíÊ ÇßÈÑ ãä 31 ÍÑÝ")

قم بتغيير الاقواس لكلمات بالعربية او الانجليزيه تكن مفهومة ... وسيعمل معك الكود كما تريد تماما ( ان شاء الله )

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

[اسلام سيد]

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

 

الاستاذ الفاضل / احمد عبد الناصر

 

الاستاذ الفاضل / حماده عمر

 

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

 

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

 

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

[احمد عبد الناصر]

السلام عليكم

 

جرب هذا 

 

تحياتي

اضافة شيت +جديد1.rar

[احمد فضيله]

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

بعد اذن كل الاخوه

الاستاذ الفاضل تابع المرفق على الرابط التالي :

http://www.officena.net/ib/index.php?showtopic=38776

[اسلام سيد]

وعليكم السلام استاذى / احمد عبد الناصر

مازالت المشكله قائمة

عند اضافه اسم شيت مكرر يقوم باضافة sheet2 - او sheet3 وهكذا

وهكذا الى انا اكتب اسم جديد

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

وهو السطر القادم

On Error Resume Next

تم تعديل أبريل 25, 2013 بواسطه إسلام الشيمي

[احمد عبد الناصر]

السلام عليكم

معذرة يبدو اني لم افهم المطلوب

والمطلوب : هو عدم اضافه شيت مكرر
 

حيث يقوم فى حاله اضافة اسم مكرر باضافه شيت جديد بدون اسم

 

الكود الاصلي الذي في الشيت ان وجد الاسم مكرر يفتح صفحة جديدة sheet2 مثلا لكن بعد ظهور رسالة خطأ .

التعديل الذي وضعته كان بغرض الغاء هذه الرساله فقط .

جرب هذا التعديل ان وجد اسم الشيت مكرر يظهر رسالة تفيد بذلك و لا يضيف اي شيتات .

 

و بالنسبة لهذا 

On Error Resume Next

فهو لتجاهل الاخطاء و المضي لتكمله الكود متجاوزا الخطأ 

 

تحياتي

اضافة شيت ++جديد1.rar

تم تعديل أبريل 25, 2013 بواسطه احمد عبد الناصر

[اسلام سيد]

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

بعد اذن كل الاخوه

الاستاذ الفاضل تابع المرفق على الرابط التالي :

http://www.officena.net/ib/index.php?showtopic=38776

 

استاذى الفاضل / احمد فضيله

 

بارك الله فيكم وفك كربكم ...  ورزكم من حيث لا تحتسبوا

 

نفس المشكله ،ملف حضرتك عند تكرار الاسم يضيف شيت جديد

[عبدالله باقشير]

السلام عليكم

بعد اذن الاساتذه

Sub newsheetcustomename()

Dim sheetname As String

sheetname = InputBox("من فضلك ادخل اسم الشيت")
If kh_Test_MyChr(sheetname) Then Exit Sub

Sheets.Add.Name = sheetname

End Sub

Function kh_Test_MyChr(khString As Variant) As Boolean
Dim MySh As Worksheet
Dim MyChArray, MyChr
Dim S As Integer, R As Integer
S = Len(Trim(khString))
If S > 31 Or S = 0 Then
    MsgBox "حروف الاسم قد تكون اصغر من 1  او اكبر من 31", 524288 + 1048576 + 16, "اسم مرفوض"
    kh_Test_MyChr = True
    Exit Function
End If
'------------------------------------
MyChArray = Array("/", "*", ":", "؟", "?", "[", "]")
For Each MyChr In MyChArray
    If InStr(1, khString, MyChr, 1) <> 0 Then
        MsgBox "حروف الاسم تحتوي على الحرف " & Chr(10) & Chr(10) & Chr(9) & MyChr & Chr(10) & Chr(10) & "وهو من الاحرف الممنوعة  " & "/ * :  ؟ [ ]", 524288 + 1048576 + 16, "حرف ممنوع"
        kh_Test_MyChr = True
        Exit Function
    End If
Next
'------------------------------------
For Each MySh In ActiveWorkbook.Sheets
    If UCase(Trim(MySh.Name)) = UCase(Trim(khString)) Then
        MsgBox "الاسم مكرر ", 524288 + 1048576 + 16, "اسم مكرر"
        kh_Test_MyChr = True
        Exit Function
    End If
Next
End Function

في امان الله

[اسلام سيد]

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

 

1 /  اشكر جميع من شارك فى الرد على  مشاركتى المتواضعه

 

2 / استاذى/ احمد عبد الناصر.....الكود الاخير لحضرتك ممتاز ( ووفى بالغرض )، فجزاك الله خيرا

 

3/ شرف لى ورب الكعبه بأن يتواجد  فى مشاركتى ، (اجابه لاخ واستاذ فاضل هو الاستاذ / عبد الله باقشير (خبور خير) ) نسأل الله أن يجمعنى معه فى عليين مع النبين والصديقين

 

والشهداء.

 

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

[حمادة عمر]

السلام عليكم

الاستاذ القدير العلامة الخبير / عبدالله باقشير

 

بارك الله فيك

كود في منتهي الروعة والدقة

وانبهر باكوادك دائما في طريقة تركيبها وخصوصا باستخدام الـ Array

نتعلم منك كل يوم شيئاً جديدا

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

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

[مجدى يونس]

الاخ خبور

رائع دائما فى اكوادك

فعلا استاذ وفنان للاكواد

وشكرا لجميع من شارك بالموضوع

[ضاحي الغريب]

لا اجمل ولا اروع من تعبير أخي ا. مجدي يونس

خبور خير ابداع بلا حدود

والشكر موصول لاخواني

اخي الحبيب / حمادة عمر

والاخ الحبيب / احمد فضيلة

والاخ الحبيب أ. أحمد عبدالناصر

والأخ الحبيب أ. أسلام الشيمي

[عبدالله باقشير]

السلام عليكم

اكرمكم الله اخواني الاحباء على هذا الاطراء

وجزاكم ربي خيرا

 

تقبلوا تحياتي وشكري

[احمد فضيله]

الاخ الحبيب الاستاذ / ضاحي الغريب

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

[احمد فضيله]

الاخ الحبيب الاستاذالعلامه / عبد الله باقشير

شهادتي لحضرتك ليس لها قيمه و لايسعني الا ان ادعو لحضرتك

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