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

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

السلام عليكم جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

السلام عليكم اخي الفاضل رجب حفظه الله جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

السلام عليكم ضع هذا الكود بين اكواد الفورم Private Sub ListFind_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Integer For i = 1 To 3 If Len(Trim(Me.Controls("TextBox" & i))) = 0 Then Me.Controls("TextBox" & i) = Me.ListFind.Value Exit For End If Next End Sub ودمتم في حفظ الله

الله يوفقك في جميع امورك وانت موجود دائما معنا في القلب تقبل تحياتي وشكري

السلام عليكم احبتي في الله الخضر-ابو سارة-ابو الحسن-نور محمود حفظكم الله ورعاكم تقبلوا تحياتي وشكري

الحل هذا معمول للاستخدام في جهاز واحد امور الشبكة هذه لا علم لي بها تقبل اعتذاري وتحياتي وشكري

السلام عليكم احبتي في الله الشهابي-دغيدي -ابوحنين حفظكم الله ورعاكم تقبلوا تحياتي وشكري

السلام عليكم احبتي في الله الشهابي-monzer2000-عبالله المجرب-ابراهيم-رجب جاويش حفظكم الله ورعاكم تقبلوا تحياتي وشكري

السلام عليكم المصفوفات الجداول تعريف مبسط : التعامل مع اكثر من قيمة واحدة تطبيقات عملية الدرس الاول : المصفوفات Arrays rArr = Array("A", "B", "C") اذا اردنا ان نضع الصفيف هذا على صف واحد وثلائة اعمدة Sub kh_1() Dim rArr rArr = Array("A", "B", "C") Range("A1").Resize(1, 3).Value = rArr End Sub اذا اردنا ان نضع الصفيف هذا على ثلاثة صفوف وعمود واحد تعرفون الدالة TRANSPOSE إرجاع نطاق خلايا عمودى كنطاق أفقي، أو بالعكس. يجب إدخال TRANSPOSE كصيغة صفيف في نطاق به نفس عدد الصفوف والأعمدة، على الترتيب، مثل صفيف الأعمدة والصفوف الخاصة به. استخدم TRANSPOSE لتبديل الاتجاه العمودي والأفقي لصفيف في ورقة عمل. بناء الجملة TRANSPOSE(array) Array (الصفيف) هو الصفيف أو نطاق الخلايا في ورقة العمل التي ترغب في تحويلها. يتم إنشاء تحويل الصفيف باستخدام الصف الأول للصفيف على أنه العمود الأول للصفيف الجديد، والصف الثاني للصفيف على أنه العمود الثاني للصفيف الجديد، وهكذا. ============================================================ Sub kh_2() Dim rArr rArr = Array("A", "B", "C") rArr = WorksheetFunction.Transpose(rArr) Range("A1").Resize(3, 1).Value = rArr End Sub يتبع لمتابعة الموضوع افضل ان تضعوا هذه الاكواد في ملف الان نقوم باضافة فورم ونضيف التالي ListBox1 CommandButton1 CommandButton2 اضف هذه الاكواد للفورم Private Sub CommandButton1_Click() Dim rArr rArr = Array("A", "B", "C") Me.ListBox1.List = rArr End Sub Private Sub CommandButton2_Click() Dim rArr rArr = Array("A", "B", "C") Me.ListBox1.Column = rArr End Sub Private Sub UserForm_Initialize() Me.ListBox1.ColumnCount = 3 End Sub بعد فتح الفورم اضغط على الازرار CommandButton1 CommandButton2 ما هي النتيجة يتبع ============================================================= المصفوفة Array("A", "B", "C") من النوع Variant وذو البعد الواحد واول دليل لعناصرها LBound صفر وآخر دليل لعناصرها UBound عدد عناصرها ناقص واحد ونضيف عناصرها دفعة واحدة ============================================================= بعض الدالات للسلاسل النصية تعطي نتائج صفيف مثل SPLIT FILTER ناخذ مثال عن SPLIT Sub kh_Split() Dim MyAr MyAr = Split("عبدالله علي احمد باقشير") Range("A1").Resize(1, UBound(MyAr) + 1).Value = MyAr End Sub =========================================================== =========================================================== =========================================================== الدرس الثاني : الجداول المفهرسة عبارة عن متغيرات مفهرسة Indexed Variables تحتوي على بيانات عديدة من نفس النوع Data Type . كل مصفوفة لها اسم واحد يمكن استخدامه للرجوع إلى أي عنصر فيها وذلك باقتران هذا الاسم بدليل يمثل مكان العنصر فيها ، ويمكن انشاء مصفوفة لإحتواء أي نوع من أنواع البيانات مثل : النصوص والأعداد الحقيقية و الصحيحة وغيرها ، فأنواع البيانات المتوفرة في الفيجيوال بيسك هي : Data Type in VB: {Byte, Boolean, Integer, Long, Single, Double, Currency, Decimal, Date, Object, String, Variant, User-defined }. واستخدام المصفوفات في البرمجة يساعد في صناعة أكواد قصيرة وبسيطة ذات قوة كبيرة لأنه يمكن بناء Loops تتعامل بكفاءة مع المصفوفات مهما كان عدد عناصرها وذلك باستخدام دليل العنصر Index Number . ================================================= الخصائص الأساسية للمصفوفة في الفيجيوال بيسك : اسم المصفوفة يمثل عنوان Address في الذاكرة ؛ ولا يمكن تغييره أثناء تنفيذ البرنامج . يمكن الإعلان عن مصفوفة لأي نوع من أنواع البيانات بما في ذلك الأنواع المعرفة من قبل المستخدم User-defined type والـ Object Variables . كل وحدة بيانات منفردة في المصفوفة تسمى عنصر Element . جميع العناصر تكون من نفس النوع إلا في حالة الإعلان عن المصفوفة كـ Variant Data Type . جميع العناصر تكون مخزنة على التتابع في ذاكرة الحاسوب ودليل أول عنصر هو الصفر كـ Default ويمكن جعله 1 باستخدام جملة في بداية الوحدة النمطية Option Base 1 لكل مصفوفة حداً أعلى Upper bound ، وحداً أدنى Lower bound ؛ وعناصر المصفوفة تكون محصورة بين هذين الحدين . من الممكن أن تكون المصفوفة ذات بعد واحد أو متعددة الأبعاد . تحديد الحدين الأعلى والأدنى للمصفوفة Upper bound & Lower bound: عند الإعلان عن مصفوفة، يكتب الحد الأعلى بعد الاسم وبين الأقواس. لا يمكن أن يزيد الحد الأعلى عن نطاق نوع المتغير Long Data Type. الحد الأدنى الإفتراضي Default هو الصفر. اذا عرفت عن هذا المتحول بـــــ Limiteinf To LimiteSup في مكان الوسيط Indexs تكون قد عرفت جدولا بعدد عناصر محدد وبارقام دليل محددة وهذه الطريقة افضل للاستخدام للفهم السريع للوسيط Indexs Dim ay(1 To 3, 1 To 2) As String ----------------------------------------------------------------------------- ay(1 To 3, 1 To 2) لمعرفة الدليل الاول والاخير لليعد الملون بالاحمر للمتحول LBound(ay, 1) UBound(ay, 1) لمعرفة الدليل الاول والاخير للبعد الملون بالازرق للمتحول LBound(ay, 2) UBound(ay, 2) ================================================================== ================================================================== ملحوظة عند إضافة أبعاد المصفوفة فإن مساحة التخزين المطلوبة سوف تزيد زيادة كبيرة ولذلك ينبغي الاحتراس وتفادي استخدام النوع Variant قدر الإمكان لما يتطلبه من مساحة تخزينية كبيرة! ================================================================== ================================================================== المصفوفة ذات الحجم الثابت نعلن عنها بأحد أوامر الإعلان (Public or Private or Dim or Static) مع تحديد عدد العناصر في الأقواس Dim ay(1 To 3, 1 To 2) As String مثال 1: Sub kh_Array1() Dim ay(1 To 3, 1 To 2) As String ay(1, 1) = "A" ay(2, 1) = "B" ay(3, 1) = "C" ay(1, 2) = "D" ay(2, 2) = "E" ay(3, 2) = "F" Range("A1").Resize(3, 2).Value = ay End Sub مثال 2 جدول ضرب Sub KH_5() Dim sArr(1 To 12, 1 To 10) As Integer Dim ContRow As Integer, ContColmn As Integer Dim c As Integer, r As Integer ContRow = UBound(sArr, 1) ContColmn = UBound(sArr, 2) For r = 1 To ContRow For c = 1 To ContColmn sArr(r, c) = r * c Next Next Range("A1").Resize(ContRow, ContColmn).Value = sArr End Sub المصفوفات متغيرة الحجم Dynamic Array: في بعض الأحيان، لا نعرف مسبقاً حجم المصفوفة التي سنستخدمها في البرنامج بالضبط، وقد نريد تغيير حجم المصفوفة أثناء تشغيل البرنامج، هنا سنحتاج إلى المصفوفات ذات الحجم المتغير Dynamic حيث يمكننا تغيير حجمها في أي وقت. تعتبر المصفوفات متغيرة الحجم أحد مميزات الفيجيوال بيسك، وهي تساعد في تنظيم الذاكرة بكفاءة. فمثلاً، يمكن استخدام مصفوفة كبيرة لوقت قصير ثم إعادة تحجيمها لتحرير مساحة من الذاكرة عندما لا نحتاجها. وهذا من شأنه تسريع المعالجة. ولصناعة Dynamic Array نتبع التالي: نعلن عنها بأحد أوامر الإعلان (Public or Private or Dim or Static) ونجعلها ديناميكية بعدم كتابة أي رقم في الأقواس كما يوضح المثال التالي: Dim sArr() As String نعيد الإعلان عنها مع تحديد عدد العناصر باستخدام جملة ReDim كما في المثال التالي: ReDim sArr(1 To ContRow, 1 To ContColmn) ================================================================== ================================================================== ملاحظات هامة . كل جملة من جمل ReDim يمكنها تغيير عدد العناصر بالإضافة إلى الحد الأعلى والحد الأدنى لكل بعد للمصفوفة، ومع ذلك فإن عدد الأبعاد في المصفوفة لا يمكن تغييره. . تمحى جميع القيم المخزنة في المصفوفة كل مرة يعاد فيها تنفيذ جملة ReDim. ويجعل الفيجيوال بيسك القيم كالتالي: في حالة الــــ Variant Array --------- الى ----- Empty Value في حالة الــــ Numeric Array ------- الى ----- Zero في حالة الــــ String Array ----------- الى ----- Zero-Length String في حالة الــــ Array of objects ------ الى ----- Nothing وهذا مفيد عندما نريد تجهيز المصفوفة لبيانات جديدة أو عندما نريد اختزال حجم المصفوفة لتأخذ أقل مساحة ممكنة في الذاكرة. ================================================================== ================================================================== مثال 1: Sub KH_6() Dim sArr() As String Dim iName As String Dim ContRow As Integer, ContColmn As Integer Dim c As Integer, r As Integer, i As Integer Range("H7").Resize(14, 5).ClearContents iName = CStr([H4]) ContColmn = 5 With Range("B7").Resize(14, 1) ContRow = WorksheetFunction.CountIf(.Cells, iName) ReDim sArr(1 To ContRow, 1 To ContColmn) For r = 1 To .Rows.Count If CStr(.Cells(r, 1)) = iName Then i = i + 1 For c = 1 To ContColmn sArr(i, c) = CStr(.Cells(r, c)) Next End If Next End With Range("H7").Resize(ContRow, ContColmn).Value = sArr Erase sArr End Sub دروس المصفوفة 1.rar ================================================================== ================================================================== Erase تستخدم لتحرير الذاكرة المعينة للجداول الديناميكية واعادة تعيين عناصر الجدول الى قيمتها البدائية بطول ثابت مثال: Erase sArr ================================================================== ================================================================== تغيير حجم المصفوفة دون فقد بياناتها يمكننا فعل ذلك باستخدام جملة ReDim مع كلمة Preserve وتعني الحفظ الجملة التالية تغير حجم المصفوفة ولكنها لا تمحو العناصر الموجودة بها: ReDim Preserve MyArray( 10 ) والآن يمكننا كتابة ملخص متكامل لجملة ReDim. جملة ReDim: تستخدم في مستوى الـProcedure لإعادة تخصيص allocates مساحة تخزينية storage space لمصفوفة متغيرة الحجم Dynamic array. صيغتها Syntax: ReDim [Preserve] varname(subscripts) [As type] [, varname (subscripts) [As type]] ================================================================== ================================================================== ملاحظات هامة: جميع ما ذكر في الصيغة داخل قوسين مربعين [] يعتبر اختياري يمكن الاستغناء عنه حين عدم الحاجة إليه. تستخدم جملة ReDim لتحجيم أو إعادة تحجيم مصفوفة متغيرة الحجم Dynamic Array والتي بالفعل قد أعلن عنها مسبقاً باستخدام أي من الجمل Dim, Private, Public مع أقواس فارغة (أي بدون ذكر الأبعاد). يمكن تكرار استخدام جملة ReDim لتغيير عدد العناصر والأبعاد لمصفوفة، ومع ذلك لا يمكن الإعلان عن مصفوفة بنوع معين من البيانات ثم إعادة تعريفها لاحقاً مع تغيير نوع البيان لنوع آخر إلا إذا كانت المصفوفة محتواه في variant. إذا كانت المصفوفة محتواه في variant فإن نوع بيان العناصر يمكن أن يتغير باستخدام المقطع As Type إلا إذا استخدمنا كلمة Preserve ففي هذه الحالة لا يسمح بتغييرات. إذا استخدمنا كلمة Preserve يمكن فقط تحجيم البعد الأخير للمصفوفة ولا يمكن تغيير عدد الأبعاد على الإطلاق. إذا كان للمصفوفة بعد واحد فيمكن إعادة تحجيم هذا البعد لأنه البعد الأخير والوحيد بالمصفوفة. وإذا كان للمصفوفة بعدين أو أكثر فيمكن فقط تغيير حجم البعد الأخير مع الاحتفاظ بمحتويات المصفوفة. عندما نستخدم Preserve يمكن تغيير حجم المصفوفة بتغيير الحد الأعلى بينما ينتج لدينا خطأ حين تغيير الحد الأدنى. إذا صنعنا مصفوفة أصغر مما كانت فإن بيانات العناصر المخزنة سوف تفقد. تحذير: جملة ReDim ستعمل وكأنها جملة إعلان إذا كان المتغير (المصفوفة) التي تعلن عنه غير موجود على مستوى الـProcedure أو الـModule. وإذا كان هناك متغير آخر بنفس الاسم قد أنشئ بعد ذلك وحتى لو كان في النطاق ككل Scope؛ فإن ReDim سوف ترجع للمتغير الأخير ولن يتسبب عن ذلك خطأ في الترجمة Compilation error حتى ولو كانت جملة Option Explicit فعّالة. وبذلك لن يدرك المبرمج أنه هناك خطأ بالشيفرة code. ولتفادي هذا التعارض لا ينبغي استخدام جملة ReDim كجملة إعلان بدلاً من Dim مثلاً، ولكن نستخدمها فقط لإعادة تعريف حجم المصفوفة. ================================================================== ================================================================== توضيح اكثر لهذه الملاحظة إذا استخدمنا كلمة Preserve يمكن فقط تحجيم البعد الأخير للمصفوفة ولا يمكن تغيير عدد الأبعاد على الإطلاق. امثلة : للبعد الاخير ( الملون بالاحمر) هنا ثلاثة ابعاد البعد الاخير هو 15 ReDim Preserve X(10,12,15) ReDim Preserve X(10,12,15) هنا بعدين البعد الاخير هو 12 ReDim Preserve X(10,12) ReDim Preserve X(10,12) هنا بعد واحد إذا كان للمصفوفة بعد واحد فيمكن إعادة تحجيم هذا البعد لأنه البعد الأخير والوحيد بالمصفوفة ReDim Preserve X(10) ReDim Preserve X(10) حمل الملف الموجود في هذا الموضوع تطبيق عملي لما ذكر اعلاه http://www.officena....showtopic=42346 http://www.officena.net/ib/index.php?showtopic=42584 دروس المصفوفة 1.rar kh_SumProduct.rar دروس المصفوفة ( دالة لتوليد ارقام عشوائية).rar ((الشرح العلمي منقول من هنا وهناك)) تم بحمد الله وشكره

السلام عليكم انسخ الكود هذا وحطه بين اكواد الفورم Private Sub TextBox35_Change() Dim Tgdeer As String Select Case Val(Me.TextBox35) Case 90.0001 To 100: Tgdeer = "مـمـــــتــــــاز" Case 80.0001 To 90: Tgdeer = "جــيـــد جـــــداً" Case 70.0001 To 80: Tgdeer = "جـــــــيـــــــد" Case 50.0001 To 70: Tgdeer = "مـــرضـــــــي" Case Else: Tgdeer = "غير مرضي" End Select Me.TextBox36.Text = Tgdeer End Sub ودمتم في حفظ الله

حفظك الله غير السطر هذا في كود البحث ib = InStr(1, .Cells(R, MyColmnFind), Me.TextFind, vbTextCompare) = 1 بهذا السطر ib = UCase(.Cells(R, MyColmnFind)) = UCase(Me.TextFind) تقبل تحياتي وشكري

السلام عليكم هل ترغب في استيرادها بزر في الملف 2 اذا اردتها عند فتح الملف 2 استخدم الكود التالي في حدث ThisWorkbook Private Sub Workbook_Open() Call kh_DateImport End Sub وهذا هو الكود : Sub kh_DateImport() Dim ib As Boolean Dim MyAr Dim MySh As Worksheet Dim MyNBook As String, MyPath As String, rAd As String On Error GoTo 1 Set MySh = ThisWorkbook.Sheets("Statment") MySh.UsedRange.ClearContents MyNBook = "ملف 1" & ".xls" MyPath = ActiveWorkbook.Path & "\" & MyNBook '--------------------------------------- ' هل الملف مغلق ib = Not Workbook_Open(MyNBook) '--------------------------------------- Application.ScreenUpdating = False ' اذا الملف مغلق يقوم بفتحه If ib Then Workbooks.Open MyPath '--------------------------------------- With Workbooks(MyNBook).Sheets("Statment") rAd = .Cells.CurrentRegion.Address MyAr = .Range(rAd).Value End With '--------------------------------------- ' اذا كان الملف مغلق سابقا يقوم باغلاقه If ib Then Windows(MyNBook).Close '--------------------------------------- MySh.Range(rAd).Value = MyAr Application.ScreenUpdating = True MsgBox "تم الاستيراد بنجاح" 1: If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If MyAr = Empty Set MySh = Nothing End Sub 'دالة لمعرفة ان كان الملف مفتوخ Function Workbook_Open(WbookName As String) As Boolean Dim wBookCheck As Workbook Application.Volatile On Error Resume Next Set wBookCheck = Workbooks(WbookName) Workbook_Open = Not wBookCheck Is Nothing On Error GoTo 0 End Function شاهد المرفق Data1-2.rar

تم التعديل اضافة الاسطر هنا قارن بين السابق وهذا Private Sub kh_Add_Controls(MyCont As Control, MyTop As Integer, iRo As Integer, MyCount As Integer) 'On Error Resume Next Dim MyTxt As Control Dim MyTyp As String Dim i As Integer For i = 1 To MyCount If i = MyCount Then MyTyp = "Forms.ComboBox.1" Else MyTyp = "Forms.TextBox.1" Set MyTxt = MyCont.Add(MyTyp, Cells(iRo, i).Address, True) With MyTxt .Move MyCont.Controls(i - 1).Left, MyTop, MyCont.Controls(i - 1).Width, MyHeight .AutoTab = True If i = MyCount Then .List = Array("تم الصرف", "لم يتم الصرف") Else .MultiLine = True .ScrollBars = 3 End If .TextAlign = 3 .Font.Bold = True .Font.Size = 12 .FontName = "Times New Roman" '=========================================== .ControlSource = "'" & Mysh_Name & "'!" & Range(.Name).Address '=========================================== End With Next i '================== Set MyTxt = Nothing '================== 'On Error GoTo 0 End Sub المرفق 2003 Listbox Form5.rar

السلام عليكم اخي الفاضل / koko 2009------------------حفظه الله اكرمك الله في الدارين وجزاك خيرا وبارك فيك واثابك بدعائك واعطاك بمثله اضعاف مضاعفة تقبل تحياتي وشكري

السلام عليكم اخي الفاضل / هاني بدر------------------حفظه الله اكرمك الله و جزاك خيرا البحث المباشر يحرك الكود لكل تغيير في التاكست وهذا ما لاتحتاجه في حالات كثيرة تقبل تحياتي وشكري

السلام عليكم اخي الفاضل / نور محمود ------------------حفظه الله جزاك الله خيرا طلبك افرد له موضوع منفصل وستجد العون من جميع الاعضاء تقبل تحياتي وشكري

تفضل استبدل بهذا Private Sub ButtonSaveFil_Click() Dim iC As Integer iC = Me.ListFind.ListCount If iC = 0 Then GoTo 1 '------------------------ Application.ScreenUpdating = False With Sheets(3) .Select .Range("A6").Resize(iC, ContColmn).Value = Me.ListFind.List End With Application.ScreenUpdating = True Unload Me 1 End Sub

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

شاهد الموضوع في الرابط ادناه وحتعرف الكثير http://www.officena.net/ib/index.php?showtopic=42261&st=0

جزاك خيرا وبارك فيك تقبل تحياتي وشكري

السلام عليكم ورحمة الله وبركاته احبتي في الله الاخ الفاضل / رجب جاويش__________ حفظه الله الاخ الفاضل / ياسر الحافظ__________ حفظه الله الاخ الفاضل / دغيدي__________ حفظه الله الاخ الفاضل / amfouad555__________ حفظه الله الاخ الفاضل / الانيس__________ حفظه الله الاخ الفاضل / الشهابي__________ حفظه الله الاخ الفاضل / ubd__________ حفظه الله الاخ الفاضل / عبدالله المجرب__________ حفظه الله الاخ الفاضل / ناصر سعيد__________ حفظه الله الاخ الفاضل / ابو الحسن__________ حفظه الله الاخ الفاضل / ابو ردينة__________ حفظه الله الاخ الفاضل / mahmoud-lee__________ حفظه الله الاخ الفاضل / عباس السماوي__________ حفظه الله الاخ الفاضل / الجزيرة__________ حفظه الله الاخ الفاضل / khhanna__________ حفظه الله الاخ الفاضل / ابو انصار__________ حفظه الله الاخ الفاضل / fidodido__________ حفظه الله الاخ الفاضل / apt__________ حفظه الله شرفتموني بحضوركم الغالي اكرمكم الله في الدارين وجزاكم خيرا وبارك فيكم واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة ودمتم في حفظ الله

السلام عليكم جمعة مباركة فورم بحث جميل وبامكانيات مرنة (وسنتعلم منه الكثير) هو طلب لاحدهم ولكني جعلته هنا لانه مهم للكثير الموضوع في الرابط ادناه http://www.officena....opic=42261&st=0 المرفق 2003-2007 ملف بحث بفورم ممتاز.rar

حفظك الله جرب الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim Num$, i% On Error Resume Next If Not Intersect(Target.Cells, Range("F12:F25,L12:L25").Cells) Is Nothing Then Num = Trim(Target) If Not IsNumeric(Num) Then Exit Sub Application.EnableEvents = False For i = 1 To 3 If Len(Num) - i Then If Target.Offset(-i, 0).Row = 10 Then GoTo 1 Target.Offset(-i, 0).Value = Mid(Num, 1, Len(Num) - i) End If Next 1: Application.EnableEvents = True End If End Sub شاهد المرفق2003 سند قيد 2.rar

السلام عليكم انصح باستخدام الدالة kh_Test_MyChr عند اعادة تسمية شيت لمعرفة اخطاء التسمية ان وجدت المرفق 2003و 2007 Sub kh_CopySheet() Dim MyName As String MyName = [F2] If kh_Test_MyChr(MyName) = True Then Exit Sub Sheets("sheet1").Copy After:=Sheets(Sheets.Count) Cells.Worksheet.Name = MyName 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 جديد.rar