تعديل بكود ترقيم تلقائي (الكود بحدث ورقة العمل)

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

اعزكم الله اليكم كود ترقيم تلقائي بحدث ورقة العمل ومهمته انه يقوم بالترقيم التلقائي بالعمود 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

 

وجزاكم الله كل الخير على مساعدتكم لى ولكل الاعضاء الى يريدون جواب لسؤالهم 

 

 

تم تعديل يوليو 25, 2017 بواسطه محمود أبوالدهب

[ياسر خليل أبو البراء]

السلام عليكم أخي محمود .. جرب الكود التالي عله يفي بالغرض

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

وإن كنت لا أحبذ الأكواد في حدث ورقة العمل إلا للضرورة .. 

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

والله استاذ ياسر لا اعرف كيف اشكرك غير بكلمه واحده وارجوا ان تقبلها وهى (((استاذى المبجل)))

وبالنسبة لحدث ورقة العمل ظنى ان طلبي صعب عن طريق فورم هو ما جعلنى اطلبها عن طريق ورقة عمل 

ولكن ان لم يزعج حضرتك واكون شاكر شاكر شاكر جدا لك ان خدمتنى وجعلت الكود يعمل على الفورم ؟

اليك ملف بسيط لتفعيل الكود علية 

مثال.rar

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

الكود الموضوع بى texbox3 مسمى لاسم text

 

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

ويكفي من كرم شخصكم ما وجدت ( تحياتى وتقدير)

ان شاء الله ادرس الكود واتعلمه في خير معلم وارجوا ان اكون تلميذ منصت وشكرا لحضرتك واسف على الاطالة 

 

 

بالنهاية ما عمل دالة ( UBound) حتى افهم باقي الكود

[ياسر خليل أبو البراء]

المشكلة أنني لست خبيراً في التعامل مع الفورم ولا أدري ما المطلوب بالضبط في الفورم .. تهت في الفورم الخاص بك

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

وأعتذر لعدم قدرتي على مساعدتك بالأمر ..إذ كيف لي أن أساعدك بشيء لا أدركه بعد !!

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

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

مثال.rar

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

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

[ياسر خليل أبو البراء]

أخي الكريم محمود جرب الكود التالي (هل هذا ما تقصده؟)

Private Sub TextBox2_Change()
    Dim ws As Worksheet
    Dim lr As Long
    
    Set ws = Sheets("الادارة الصحية")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    TextBox1.Value = lr - 1
End Sub

 

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

اشكرك استاذى ومعلمى ياسر خليل ولكن هذا لم اكن اقصدة ما قصده هو كود يوضع بي textbox2 مسئول عن ترقيم textbox1 

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

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

[ياسر خليل أبو البراء]

حاول توضح أكتر .. 

الأفضل من وجهة نظري أن تكون البيانات متتالية ولا يفصل بينها فاصل .. سطر فارغ كما تريد

وإذا كنت تريد ذلك ما الذي سيحدد الصف الفارغ .. ربما كفكرة أن تقوم بإنشاء CheckBox وإذا كانت قيمتة True يتم زيادة قيمة المتغير lr بمقدار 2 ويعطي تسلسل جديد يبدأ من 1 ..

ما زالت الفكرة غير مكتملة لربما لعد وضوح الرؤية بالنسبة لي

قم برسم مربع CheckBox1 وجرب الكود التالي عله يفي بالغرض

Private Sub TextBox2_Change()
    Dim ws As Worksheet
    Dim lr As Long
    
    Set ws = Sheets("الادارة الصحية")
    lr = ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value + 1
    
    If CheckBox1.Value = True Then lr = 1
    TextBox1.Value = lr
End Sub

 

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

الذى سيحدد السطر الفارغ هو رز به كود مرتبط بالرقم التامينى اى العمود c وهو في الترحيل هو lastrow وعليه من خلاله ادخل اسم السجل الجديد 

وعليه يصبح ما مقابل من العمود b فارغ يصبح c51 مثلا "سجل عام 2017" و c51 = ""

ثم c52 = "الرقم التامينى" و b52 = "الاسم " و a52 = "التسلسل"

بالصورة الؤز الذى يفتح فورم الذى يضع اسم السجل

وبعدها يكون b و a فارغ و c به اسم السجل

اتمنى ان تكون الصورة وضحت

 

[ياسر خليل أبو البراء]

تمام .. بعد الضغط على إدخال جديد يتم تعبئة الصف في الأعمدة الثلاثة الأولى ..أم بالعمود الأول فقط

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

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

اسف جائني ضيوف ولم استطيع ان اجيب سيادتكم سريعا.

1- بالنسبة للتعبئة فهى حرة اطوعها كما يخدمنى الكود سواء اول ثلاث اعمده او اى عمود انا حاليا مصممه انه من العمود الثانى حتى العمود السابع ان يدخل نفس العبارة والعبارة حرة يدخلها المستخدم كما يريد 

المثال بالصورة المرفقة 

2- فممكن ان نقول اذا كان text من 2 الى 7 متساويين فيبدء الترقيم من جديد  , ولان البيان لا يحتوى على كلمات محدده فهى متروكة لرغبت المستخدم 

او ما تريد وبالامكان تعديل كود الترحيل  

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

وشكرا جزيلا .

واتمنى بالنهاية ان يبدء الترقيم من a4 وليس a1 .

 

تم تعديل يوليو 26, 2017 بواسطه محمود أبوالدهب

[ياسر خليل أبو البراء]

أخي الكريم محمود

ربما لو وضعت شرط أن آخر خلية بالعمود B لا تساوي فراغ والخلية المجاورة لها فارغة يبدأ الترقيم الجديد .. هذا والله أعلم

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

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

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

 

[ياسر خليل أبو البراء]

إذاً فلتحاول وإذا تعثرت في نقطة معينة أخبرنا بها .إذ لا يمكنني العمل على التخمين 

وفقك الله

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

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

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

 

فالحقيقة ان الترقيم  عن طريق الفورم اخى العزيز ياسر لا مشكلة به"" ولكن تثور المشكلة انى حديث في عالم الاكواد اينعم اجتهد وابحث ولكن لانى علمى مقتصر على قرائت التعليقات ومشاهدة الفديوهات التى لا توصل كل شي تريده جيدا واحاول التطبيق لاصل الى ما اريد "" المهم انى وضعت كود يرقم عاددى البيانات من 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   "" والله اعلم انك في خاطرى اعلى اجل من هذا اى عدم الاستطاعة ولكن لانك لم تتعامل مع الفورم كثيرا فقد لا تستطع ""

وفي النهاية اسف على ازعاج سيادتكم والاطالة 

وفقق الله لمساعدة المحتاج مثلي (" فليست الحاجة فقط تقتصر على المال ولكنها تمتد وتشمل الكثير ") 

 

 

[ياسر خليل أبو البراء]

السلام عليكم ..

على سبيل التخمين لأنني لا أدري ما المطلوب إلى الآن .. جرب الكود التالي

Sub text()
    Dim ws As Worksheet
    Dim a As Variant
    Dim c As Range
    Dim i As Long
    Dim r As Long
    Dim ss As Long
    
    Set ws = ActiveSheet
    a = ws.Range("A2:B" & ws.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

    ws.Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a
    TextBox2.Visible = True
    TextBox5.Visible = False

    If Me.TextBox6.Value <> "" Then
        ss = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Me.TextBox2.Value = ss
    Else
        Me.TextBox2.Value = ""
    End If
End Sub

 

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

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

تم تعديل يوليو 26, 2017 بواسطه محمود أبوالدهب

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

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

    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

 

تم تعديل يوليو 26, 2017 بواسطه محمود أبوالدهب

[ياسر خليل أبو البراء]

الحمد لله أن تم المطلوب على خير

المشكلة في أي موضوع هي فهم المعطيات الخاصة بالموضوع .. وفي رأيي أن أي مشكلة حلها بنسبة 90% يكمن في فهم المشكلة ..

عموماً الحمد لله ...

بالنسبة للجزء الذي تسأل عنه نعم بالمصفوفة .. والمصفوفة أسرع في التعامل من الحلقات التكرارية العادية

شاهد الفيديو التالي لتعرف الفرق بين السرعات