محمود أبوالدهب

الحمد لله استاذى ومعلمى الجليل لقد عمل الكود بمنتهى الكفائة وحلت المشكلة بتغير اخر الكود لهذا التعديل البسيط If Me.TextBox6.Value <> "" Then ss = ws.Cells(Rows.Count, 1).End(xlUp).text Me.TextBox2.Value = ss + 1 Else Me.TextBox2.Value = "" End If ملحوظة وانته لا تفهم ما اريده جيدا اخرجت لى هذا الكود الذى اعمل على ان اجده منذ امد بعيد وهو في منتهى الروعه فما بالك لو فهمت ما اريده لكنت صممت لى الملاين من البرامج فى ثانية اشكرك جزيلا سؤال بالاخر هل الكود عبارة عن مصفوفة ام ماذا وما معنى هذا الجزء لو امكن For i = LBound(a, 1) To UBound(a, 1) If a(i, 2) <> "" Then r = r + 1: a(i, 1) = r Else r = 0: a(i, 1) = "" End If Next i

الكود يعمل بامتياز ولكن ينقصه شي وهو اظهار الرقم الى المفروض يرحل في textbox2 بيظهر رقم خطا ولكن عند الترحيل يرحل صحيح

هههههههههههه والله كان هذا شعورى ان هذا سيكون رد حضرتك لانى عندما عدت وقرئت التعليقات وصلتنى فكرت انك ترشدنى وانا كنت اظنك انك تساعدى اى تفهم ما اريد لتعدل الكود السابق اعطائة لى بحدث ورقة العمل ككود للفورم فالحقيقة ان الترقيم عن طريق الفورم اخى العزيز ياسر لا مشكلة به"" ولكن تثور المشكلة انى حديث في عالم الاكواد اينعم اجتهد وابحث ولكن لانى علمى مقتصر على قرائت التعليقات ومشاهدة الفديوهات التى لا توصل كل شي تريده جيدا واحاول التطبيق لاصل الى ما اريد "" المهم انى وضعت كود يرقم عاددى البيانات من 1 ثم 2 وهكذا وهو كالتالى Sub text() TextBox2.Visible = True TextBox5.Visible = False Dim was As Worksheet Dim c As Range Set was = ActiveSheet If Me.TextBox6.Value <> "" Then ss = WorksheetFunction.CountA(was.Range("a2:a1000000")) Me.TextBox2.Value = ss Else Me.TextBox2.Value = "" End If End Sub ولكن لا استطيع التعديل عليه ليبدء بالترقيم من جديد او ان يقوم باعادت ترقيم كل الورقة في حالة اضافت سطر او حذف سطر فهذا صعب جدا عليا بتلك المرحل وكنت ارجوا مساعدة الخبراء ولكن اشهد الله انى منذ يوم الاربعاء السابق اى منذ 8 ايام وانا لا يقل عن خمسة وستة ساعات متواصلة بحث بالامر ولكن لا استطيع تطويعه لما ارغب فيثور التسأول هنا هل بامكان سيادتكم ان تساعدنى بالذات في الكواد الاول الذى اعطيتنى اياه وهو Private Sub Worksheet_Change(ByVal Target As Range) Dim a As Variant Dim i As Long Dim r As Long a = Range("A2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value For i = LBound(a, 1) To UBound(a, 1) If a(i, 2) <> "" Then r = r + 1: a(i, 1) = r Else r = 0: a(i, 1) = "" End If Next i Application.EnableEvents = False Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a Application.EnableEvents = True End Sub ان تعدله يعمل نفس ما يفعله حاليا عن طريق الفورم من تررقيم واعادة ترقيم لكل صفحات العمل عند اضافة سطر او حذف سطر وان يراعي ترقيم السجلات الجديده ؟ او على الاقل ان لم تستطع ان تعدل الكود ليرقم من الخلية a3 وليس من الخلية a1 "" والله اعلم انك في خاطرى اعلى اجل من هذا اى عدم الاستطاعة ولكن لانك لم تتعامل مع الفورم كثيرا فقد لا تستطع "" وفي النهاية اسف على ازعاج سيادتكم والاطالة وفقق الله لمساعدة المحتاج مثلي (" فليست الحاجة فقط تقتصر على المال ولكنها تمتد وتشمل الكثير ")

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

اسف جائني ضيوف ولم استطيع ان اجيب سيادتكم سريعا. 1- بالنسبة للتعبئة فهى حرة اطوعها كما يخدمنى الكود سواء اول ثلاث اعمده او اى عمود انا حاليا مصممه انه من العمود الثانى حتى العمود السابع ان يدخل نفس العبارة والعبارة حرة يدخلها المستخدم كما يريد المثال بالصورة المرفقة 2- فممكن ان نقول اذا كان text من 2 الى 7 متساويين فيبدء الترقيم من جديد , ولان البيان لا يحتوى على كلمات محدده فهى متروكة لرغبت المستخدم او ما تريد وبالامكان تعديل كود الترحيل الفكرة اذا جعلت لكل سجل شيت لوحده مع برنامج اعمل فيه على الاستمرارية , سيون كبير ديد والبحث فيه سيكون متعب اما اذا كانت البيانتا تحت بعضها فيسهل الامر , ولان ميزته تظهر مع الاستمراية فبعد عام او عامين او ثلاثة سيكون البحث بالسجل الورقي مرهق وقد لا اعرف باى واحد ابحث اولا لان الاسم قد يتكرر في جميع السجلات وبيانات مختلفه فقد اتر الى وضع سجلات على مكتبي تصل لى خمس سنوات واحيانا عشر سنوات للبحث في بعضها وهذا يرق كثيرا ولانى اعمل على الا اقتر فيه على البيانات المختصرة ولكن ساقوم بتحديثه ليرل جميع البيانات ويتم الاستغناء بعدها عن السل الورقي. وشكرا جزيلا . واتمنى بالنهاية ان يبدء الترقيم من a4 وليس a1 .

الذى سيحدد السطر الفارغ هو رز به كود مرتبط بالرقم التامينى اى العمود c وهو في الترحيل هو lastrow وعليه من خلاله ادخل اسم السجل الجديد وعليه يصبح ما مقابل من العمود b فارغ يصبح c51 مثلا "سجل عام 2017" و c51 = "" ثم c52 = "الرقم التامينى" و b52 = "الاسم " و a52 = "التسلسل" بالصورة الؤز الذى يفتح فورم الذى يضع اسم السجل وبعدها يكون b و a فارغ و c به اسم السجل اتمنى ان تكون الصورة وضحت

اشكرك استاذى ومعلمى ياسر خليل ولكن هذا لم اكن اقصدة ما قصده هو كود يوضع بي textbox2 مسئول عن ترقيم textbox1 والترقيم يكون بشروط الشروط هى هى نفس الشروط الى حضرتك تفضلت عليا بالاعلى وحلتلى المشكلة بحدث الورةة فلو امكن تعديل الكود الى بالاعلى ليناسب الفورم ويؤدى نفس النتيجة اكون شاكر جدا لحضرتك واذا لم يكن بالامكان ذالك ارجوا التوضيح اعزكم الله

للرفع فرع الله قدركم وشأنكم واطال عمركم

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

والله استاذ ياسر لا اعرف كيف اشكرك غير بكلمه واحده وارجوا ان تقبلها وهى (((استاذى المبجل))) وبالنسبة لحدث ورقة العمل ظنى ان طلبي صعب عن طريق فورم هو ما جعلنى اطلبها عن طريق ورقة عمل ولكن ان لم يزعج حضرتك واكون شاكر شاكر شاكر جدا لك ان خدمتنى وجعلت الكود يعمل على الفورم ؟ اليك ملف بسيط لتفعيل الكود علية مثال.rar بى textbox3 الرقم التامينى اذا وجد به اى رقم يرقم في textbox2 بنفس الخصائص والشروط السابقة من اضافة وحذف للسطور الفورم مأخوذ كوبى من العمل الاصل قد يكون هناك بعض الازرار فيه لا تعمل الكود الموضوع بى texbox3 مسمى لاسم text انا عارف انى برهق حضرتك ولكن منك اتعلم واستفيد وان لم تستطيع ان تساعدنى حاليا ارجوا ردا من سيادتكم حتى اطوع الكود السابق في العمل الخاص بي ويكفي من كرم شخصكم ما وجدت ( تحياتى وتقدير) ان شاء الله ادرس الكود واتعلمه في خير معلم وارجوا ان اكون تلميذ منصت وشكرا لحضرتك واسف على الاطالة بالنهاية ما عمل دالة ( UBound) حتى افهم باقي الكود

اعزكم الله اليكم كود ترقيم تلقائي بحدث ورقة العمل ومهمته انه يقوم بالترقيم التلقائي بالعمود a اذا وجدت بيانات بالعمود b ثانياا يقوم باعادة الترقيم ثانيتا عند اضافة سطر insetrow بمعنى الترقيم من 1 الى 50 وبالعمود 40 ااضفت سطر بالخلية b40 اضفت بيان يقوم بضبط الترقيم لكل الادخالات ثانيتا ثالثا نفس الامر بالحذف المطلوب اعزكم واجلكم الله تعديل على هذا الكود بحيث يقوم الكود في حالة ما اذا كان ما بالخلية كما بالمثال السابق b51 فارغة وتمت الكتابة بالخلية b52 يقوم ببدء الترقيم ثانيتا من 1 بالخلية a52 كما بالصورة والكود هو Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then ' ActiveSheet.Unprotect Password:=123 If Target.Value <> "" Then With Cells(Target.Row, Target.Column - 1) .FormulaR1C1 = _ "=IF(COUNTA(RC[1]:RC[1])=1,COUNTA(R2C[1]:RC[1]),"""")" End With Else Cells(Target.Row, Target.Column - 1).ClearContents End If End If ' ActiveSheet.Protect Password:=123, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub ومرفق ملف به الكود للتعديل علية مثال.rar وجزاكم الله كل الخير على مساعدتكم لى ولكل الاعضاء الى يريدون جواب لسؤالهم

اشكرك اخى وملعمى الكريم ياسر جارى انشاء موضوع جديد

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

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

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

تفضل اخى فورم للترحيل هذا ما تعلمته هنا من اساتذتى نموذج.rar

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

؟

للرفع رفع الله شأنكم واطال عمركم

للرفع

للرفع

ارجوا التعديل على هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then ' ActiveSheet.Unprotect Password:="" If Target.Value <> "" Then With Cells(Target.Row, Target.Column - 1) .FormulaR1C1 = _ "=IF(COUNTA(RC[1]:RC[1])=1,COUNTA(R2C[1]:RC[1]),"""")" End With Else Cells(Target.Row, Target.Column - 1).ClearContents End If End If ' ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub فكرة عمله انه يقوم بترقيم العمود a تلقائيا اذا كان العمود ("" <> b) ولو تم حذف عمود او اضافة عمود يقوم باعادة الترتيب التلقائي ثانيتا فبرجاء التعديل عليه ليصبح اذا ما كان ما بالعمود b c d e f g يساوى بعض يبدء التؤقسم من جديد يعنى اذافة شرط اف مثلا كنت بالف 50 وكان الترقيم بالعموم a الى الصف 50 مظبوط وعند الصف 51 كان الادخال بالعموم b و c و d و e و f بهم كلمت مسلسل او محمود اى جمله شبة بعض يبد من جديد في العموم a52 الترقيم من 1 ثم 2 وهكذا وشكرا لكم واسف على الاطالة

يظهر طلبي مكنش وواضح بالفديو سف للاطالة المطلوب انه في textbox2 موجود فيه كود ترفيم اروجو تعديل الكود واضافة كود جديد في comndbotton ( سجل جديد) بحي انى بمجرد ما اضغط على سجل جديد فيقوم الكود الخاص بالترقيم ببدء ترقيم جديد مثال على ذالك وصلت الى رقم وليكن 60 واريد اضافة سجل جديد بعدها بمجرد الضغط على سجل جديد يقوم الكود باضافة كلمة سجل جديد ( 2 او 3 او 4 على حسب ما قبله يعنى لو الى قبله سجل 4 يكتب سجل جديد 5 وهكذا ) وبعد اضافة كلة سجل جديد يبدأ الترقيم من جديد 1 و 2 و 3و 4و5و6و7و8و9و10 وهككذا اتمنى ان الامر يكون وضح ملحوظة textbox2 موضوع تحت textbox5 والاتنين تحت مسمي (مسلسل) وايضا تم تير اسم الشيت الى sh1 و sh2 وهكذا وايضا كود الترقيم بالاخر تحت مسمي sub text وشكرا لكم جميعا

نرجوا من الخبراء الافاضل عزهم الله الاطلاع على هذا الفديو فبة المطلوب وبه رجاء لو بالامكان نظره سريعة على العمل لانه اول عمل لى تعلمته من الساده الخبراء الافاضل من موضيع قديمة ومن سؤالهم هناالمصنف2.rar وشكرا لكم جميعا المصنف2.rar

يمكن ذالك عن طريق اتباع الشرح الخاص باستاذنا الجليل ياسر خليل بالاعلى او كما يمكن ذالك عن طريق وضع الكود الحالى بثلاث صيغ والدلاله واحده بالنهاية Private Sub UserForm_Initialize() 'الطريقة الاولى If Label1.Caption <> "" Then Label1.Caption = Sheets(1).Range("a1").Value End If 'الطريقة الثانية Label2.Caption = Range("b1") 'الطريقة الثالثة Label3.Caption = Range("c1").Value 'CommandButton 'الطريقة الاولى If Label1.Caption <> "" Then CommandButton1.Caption = Sheets(1).Range("a2").Value End If 'الطريقة الثانية CommandButton2.Caption = Range("b2") 'الطريقة الثالثة CommandButton3.Caption = Range("c2").Value End Sub ومرفق ملف لتوضيح الامر 1010.rar كما بالامكان البحث بالموضوعات القديمة وستجد كل ما ترغب به ان شاء الله ومثال على ذالك الرابط التالى