اذهب الي المحتوي
أوفيسنا

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

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

ارجو الساعده فى عمل الاتى اريد بعد الضغط على زر انشاء شيت جديد وظهور 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

رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

السلام عليكم

جرب هكذا


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

تسلم ايديك

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

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

بارك الله فيك

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
×
×
  • اضف...

Important Information