طلب كود او معادلة للترقيم التلقائي برقم الصفحة

[mahmoudslah]

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

  كما هو موضح بالمرفق     { المطلوب ان يكون رقم الكرت = نفس رقم الصفحة على ان يكون ترقيم تلقائي في حالة الغاء كرت او ايضافة كرت في نصف الملف او نقل كرت يتم تعدل رقم الكرت تلقائياً  بنفس رقم الصفحة  حيث ان الكروت تصل ال 500 كرت اقوم بتعديلهم باليد ( ترقيم يدوي )  كل مرة يتم نقل اوحذف او إيضافة كرت   

ارجو الافادة   

 جزاك الله عنا كل خير

 

1.rar

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

ضع الكود التالي في حدث المصنف ... سيعمل الكود عند تنشبط ورقة العمل (جرب الانتقال لورقة أخرى وارجع لورقة العمل وسيعمل الكود)

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Sh.Range("F6").Value = Sh.Name
End Sub

 

[سليم حاصبيا]

2 دقائق مضت, ياسر خليل أبو البراء said:

ضع الكود التالي في حدث المصنف ... سيعمل الكود عند تنشبط ورقة العمل (جرب الانتقال لورقة أخرى وارجع لورقة العمل وسيعمل الكود)

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Sh.Range("F6").Value = Sh.Name
End Sub

 

اخي ياسر

لا اعرف اذا كنت اطلعت على الملف يشكل جيد او لا  لان كل شيت تحتوي على اكثر من كرت بينهم  تسلسل 30

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

بارك الله فيك أخي الحبيب سليم

اطلعت على الملف ووضعت الكود بناء على فهمته من الشرح وإن كان غير ذلك ننتظر رد الأخ السائل ..

جزيت خيراً على الاهتمام بالموضوع .. تقبل وافر تقديري واحترامي

[سليم حاصبيا]

1 دقيقه مضت, ياسر خليل أبو البراء said:

بارك الله فيك أخي الحبيب سليم

اطلعت على الملف ووضعت الكود بناء على فهمته من الشرح وإن كان غير ذلك ننتظر رد الأخ السائل ..

جزيت خيراً على الاهتمام بالموضوع .. تقبل وافر تقديري واحترامي

انا سبقتك الى ذلك بهذا الكود عسى ان ينال الاعجاب

Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
find_row
End Sub
'=============================================================
Sub find_row()
Dim my_sh As Worksheet
Dim rg_to_find As Range
Dim search_word As String
Dim r, r1 As Integer

search_word = "رقم الكرت"
Set my_sh = ActiveSheet
 Set rg_to_find = my_sh.Range("e:e").Find(search_word, lookat:=xlWhole)
  If Not rg_to_find Is Nothing Then r1 = rg_to_find.Row: Cells(r1, "f") = my_sh.Name
   
    Do Until r1 = r
            Set rg_to_find = my_sh.Range("e:e").FindNext(after:=rg_to_find)
            r = rg_to_find.Row
            Cells(r, "f") = my_sh.Name
     Loop
 End Sub

 

[ابراهيم الحداد]

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

جرب ان تضع هذا الكود فى حدث الصفحة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 6 Then Exit Sub
Dim LR As Long, R As Integer, x As Integer
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For R = 6 To lngLstRow Step 30
If True Then
x = x + 1
Cells(R, "F").Value = x
End If
Next
End Sub

 

[سليم حاصبيا]

19 دقائق مضت, زيزو العجوز said:

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

جرب ان تضع هذا الكود فى حدث الصفحة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 6 Then Exit Sub
Dim LR As Long, R As Integer, x As Integer
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For R = 6 To lngLstRow Step 30
If True Then
x = x + 1
Cells(R, "F").Value = x
End If
Next
End Sub

 

اخي زيزو الكود الذي رفعته يعمل بشكل ممتاز في حال كان تسلسل رقم الكرت (كل 30 صف) فقط و في حال الزيادة او النقصان تختلط الامور

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

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

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

[ابراهيم الحداد]

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

اخى الكريم الاستاذ سليم

تعليقك رائع وفعلا فى محله

بارك الله فيك

[mahmoudslah]

شكراً  على المساعدة  بارك الله فيكم اجمعين  

 جزاك الله عنا كل خير 

تم تعديل مايو 10, 2017 بواسطه mahmoudslah