كود اضافة شيت جديد

[إبراهيم ابوليله]

الاخوه الكرام تحيه طيبه وبعد

ارجو الساعده فى عمل الاتى اريد بعد الضغط على زر انشاء شيت جديد وظهور USERFORM1 اريد ان اقوم بكتابة اسم او رقم فى TEXT BOX1 ثم الضغط على زر اضافة شيت فيتم انشاء شيت جديد فارغ بنفس الاسم الذى تم كتابته فى TEXT BOX1

اضافة شيت.rar

[الـعيدروس]

السلام عليكم

حط هذا الكود في حدث الفورم

Private Sub CommandButton1_Click()

Dim SH As Worksheet

A = Me.TextBox1

Set SH = Worksheets.Add

SH.Name = A

SH.Move After:=Sheets(Sheets.Count)

ActiveSheet.DisplayRightToLeft = False

End Sub

[أبو محمد عباس]

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

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

نسال الله سبحانه وتعالى ان يديم نعمه عليك ويعطيك الصحة والعافية

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

[حامد يونس]

السلام عليكم

وهذا حل اخر , اضافة للحل في المشاركة رقم2

Private Sub CommandButton1_Click()

  Sheets.Add After:=Sheets(Sheets.Count)

	Sheets(Sheets.Count).Select

	Sheets(Sheets.Count).Name = TextBox1.Text

End Sub

[إبراهيم ابوليله]

اضافة شيت.rar

1. الاخوه الكرام مشكورا لمجهوداتكم
   
2. ولكنى اريد ايضا عمل الاتى
   
3. منع تكرار كتابه اسم مرتين
   

[الـعيدروس]

السلام عليكم

جرب هكذا

Private Sub CommandButton1_Click()

Dim SH As Worksheet

Dim T As Worksheet

A = Me.TextBox1

For Each T In Application.Worksheets

If Not T.Name = A Then

GoTo 0

Else

M = M & "إسم الورقة موجود مسبقاً"

GoTo 1

End If

Next T

Exit Sub

0:

Set SH = Worksheets.Add

SH.Name = A

SH.Move After:=Sheets(Sheets.Count)

ActiveSheet.DisplayRightToLeft = False

Exit Sub

1:

MsgBox M

End Sub

[رجب جاويش]

بعد أذن الأخ الفاضل / thair younus

هذا تعديل بسيط على الكود لمنع تكرار أسماء الصفحات

وأيضا لا يسمح بترك الاسم فارغا

Private Sub CommandButton1_Click()

Dim sh As Worksheet

If TextBox1.Text = "" Then MsgBox "ÇÓã ÇáÔíÊ áÇ íäÈÛì Ãä íßæä ÝÇÑÛÇ": Exit Sub

For Each sh In ThisWorkbook.Worksheets

If sh.Name = TextBox1.Text Then MsgBox "åÐÇ ÇáÇÓã ãæÌæÏ ãä ÞÈá", vbOKOnly, "ÇÓã ÔíÊ ãßÑÑ": Exit Sub

Next

  Sheets.Add After:=Sheets(Sheets.Count)

	    Sheets(Sheets.Count).Select

	    Sheets(Sheets.Count).Name = TextBox1.Text

	    TextBox1.Text = ""

	    Me.Hide

End Sub

اضافة شيت.rar

[حامد يونس]

بعد أذن الأخ الفاضل / thair younus

هذا تعديل بسيط على الكود لمنع تكرار أسماء الصفحات

وأيضا لا يسمح بترك الاسم فارغا

Private Sub CommandButton1_Click()

Dim sh As Worksheet

If TextBox1.Text = "" Then MsgBox "ÇÓã ÇáÔíÊ áÇ íäÈÛì Ãä íßæä ÝÇÑÛÇ": Exit Sub

For Each sh In ThisWorkbook.Worksheets

If sh.Name = TextBox1.Text Then MsgBox "åÐÇ ÇáÇÓã ãæÌæÏ ãä ÞÈá", vbOKOnly, "ÇÓã ÔíÊ ãßÑÑ": Exit Sub

Next

  Sheets.Add After:=Sheets(Sheets.Count)

		Sheets(Sheets.Count).Select

		Sheets(Sheets.Count).Name = TextBox1.Text

		TextBox1.Text = ""

		Me.Hide

End Sub

الاستاذ رجب جاويش

لمسات محترفة من شخص محترف

[إبراهيم ابوليله]

مشكورا لكم اهتمامك وبارك الله فيكم

[حامد يونس]

الاستاذ رجب

ما رأيك بهذا التعديل

Private Sub CommandButton1_Click()

    Dim cnt As Integer


    cnt = Sheets.Count


    For i = 1 To cnt

	    If Sheets(i).Name = TextBox1.Value Then

		    MsgBox "åÐÇ ÇáÇÓã ãæÌæÏ ãÓÈÞÇ"

		    Exit Sub

	    End If

    Next

    Sheets.Add After:=Sheets(Sheets.Count)

    Sheets(Sheets.Count).Select

    Sheets(Sheets.Count).Name = TextBox1.Text

End Sub

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

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

بارك الله فيكم جميع المشاركين

ولاثراء الموضوع

هناك ايضا موانع اخرى لتسمية ورقة العمل

وهي :

- طول الاسم يجب الا يكون اكبر من 31

- وبعض الاحرف ممنوعة في التسمية

MyChArray = Array("/", "*", ":", "؟", "?", "[", "]")

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

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

وهذا كود الاضافة بمعية الدالة

Sub kh_Addsheet()

Dim MyName As String

Dim xlSheet As Worksheet

MyName = TextBox1.Value

If kh_Test_MyChr(MyName) = True Then Exit Sub

Set xlSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))

xlSheet.Name = MyName

Set xlSheet = Nothing

End Sub

ودمتم

[الـعيدروس]

السلام عليكم

إختصار للكود

Private Sub CommandButton1_Click()

Dim T As Worksheet

For Each T In Application.Worksheets

If Not T.Name = Me.TextBox1 And Not Me.TextBox1 = Empty Then

Sheets.Add(After:=Sheets(Sheets.Count)).Name = Me.TextBox1: Exit Sub

Else: MsgBox "مسمى مكرر": Exit Sub

End If

Next T

End Sub

[الـعيدروس]

السلام عليكم

أستاذنا الحبيب عبدالله باقشير حفظك الله ورعاك

دالة جميله وأكوادك كالعادة إحترافيه

وفقك الله

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

وهناك ملاحظة اثناء نسخ كود فيه كلمات عربية

قبل النسخ حول اللغة في الاكسل الى العربية

ثم قم بالنسخ

ستظهر اللغة العربية بشكلها الصحيح وليست طلاسم

ودمتم

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

السلام عليكم

أستاذنا الحبيب عبدالله باقشير حفظك الله ورعاك

دالة جميله وأكوادك كالعادة إحترافيه

وفقك الله

بارك الله فيك اخي ابو انصار

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

[حامد يونس]

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

نبقى تلاميذ صغار امامك

[رجب جاويش]

الأخ /thair younus

تسلم ايديك

الأستاذ / عبد الله باقشير

دائما أستاذ الأساتذة

بارك الله فيك

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

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

نبقى تلاميذ صغار امامك

الأخ /thair younus

تسلم ايديك

الأستاذ / عبد الله باقشير

دائما أستاذ الأساتذة

بارك الله فيك

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

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

[إبراهيم ابوليله]

الاخوه الاساتذه الافاضل

بارك الله فيكم

وجعلم دائما فيمن ينفعون بعلمهم