تعديل كود حذف

[فتحى ابوالفضل]

الاخ الفاضل / ابراهيم الحداد

في المرفق كود لسيادتكم قمتم بإعداده من فترة و عند استخدامه في المرفق يؤدي العمل المطلوب منه في الحذف

ولكن

نظراُ لوجود معادلة في الخلية A7 مرتبطة بالخلية C 5 فإنه عند تطبيق الكود يحدث خطأ في التنسيقات و الترقيم

برجاء المساعدة

جزاكم الله خيرا

مرتب جديد - - 1.rar

[احمد بدره]

بعد إذن أستاذنا الفاضل أستاذ إبراهيم الحداد

قم باستخدام معادلة الترقيم هذه  ولا داعي لارتباط الخلية A7 بالخلية C5 

=IF(B7="";"";SUBTOTAL(3;$B$7:B7))

إن لم تعمل عمل جهازك استخدم  هذه  ( أي استبدال الفاصلة بالفاصلة المنقوطة أو العكس ) تبعًا لنسخة الأوفيس لديك

=IF(B7="","",SUBTOTAL(3,$B$7:B7))

 

[فتحى ابوالفضل]

الأخ الفاضل / احمد بدره

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

ولكن

وجود الربط بين الخلية A7 و الخلية c5  حتى احصل على جدول متغير حسب العدد الذي اكتبه في الخلية C5

فلو كان عدد الموظفين 100 و تم كتابة العدد 100 في الخلية c5 سأحصل على عدد 100 صف و هكذا ( جدول متغير حسب قيمة c5 )

اشكر حضرتك على المساعدة القيمة و جزاك الله كل خير

[احمد بدره]

=COUNTA(B7:B1000)

ممكت تجرب المعادلة هذه في الخلية C5  حيث تأتي بعدد الموظفين الذين تم تسجيلهم

 

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

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

استخدم الكود التالى بزر مستقل

Sub FormatRows()
i = 7
x = [C5].Value + 6
Do Until i > x
Cells(i, 1) = i - 6
i = i + 1
Loop

 

[فتحى ابوالفضل]

الأخ الفاضل / ابراهيم الحداد

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

وعند اضافة end sub

فإنه لا يعمل

 

تم تعديل يونيو 23, 2019 بواسطه فتحى ابوالفضل

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

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

عذرا لقد تم النسخ خطأ فالكود يعمل لدى بكفاءة

و لكن الكود التالى افضل و اسرع

Sub FormatRows()
Dim i As Long, x As Long, LR As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
If LR < 7 Then
LR = 7
Else
End If
Range("A7:A" & LR).ClearContents
i = 7
x = [C5].Value + 6
Do While i <= x
Cells(i, 1) = i - 6
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

 

[فتحى ابوالفضل]

الأخ الفاضل / ابراهيم الحداد

دام الله فضلكم

اولا : جزاك الله كل خير

ثانيا : اثقلت على حضرتك

ثالثا : تم اضافة كود حضرتك و لكن حدث ما يلي

1 – لم يتم حذف الصف

2 – عند الضغط على زر الحذف يتم الغاء المعادلة الموجودة في الخلية A7   مع العلم بأن الخلية A7  لها ربط مع الخلية C5  للحصول على جدول متغير حسب ما يتم كتابتة من العدد في الخلية C5  

و المطلوب

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

و مرسل لحضرتك مرفق قبل اضافة الكود و بعد الاضافة

دمتم و دام فضلكم

المرتب.zip

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

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

تم دمج الكودين السابقين حتى يعملا ككود واحد

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

رجاء جعل الاسماء فى عمود "B" فقط و المسلسل فى عمود "A"

سيقوم الكود بالحذف و الترقيم فى آن واحد حتى يتم المحافطة عاى التنسيقات

الكود سيكون بطئ نوعا ما

عسى الله ان اكون قد وفقت

اليك الكود :

Sub DelRows()
Dim Sh As Worksheet, Msg As String
Dim Nam As String
Dim i As Long, x As Long, LR As Long
Nam = ActiveCell.Value
Application.ScreenUpdating = False
Msg = MsgBox("من كافة الشيتات" & " " & Nam & " " & "هل تريد فعلا ازالة السيد / ", vbYesNo)
For Each Sh In Worksheets(Array("ادخال بيانات 155", "بدلات 155", "نقابات 155", "استقطاعات 155", _
"جزاءات 155", "بيانات معلمين", "مرتب 155-1", "مرتب 155", "ادخال بيانات 81", "نقابات 81", _
"استقطاعات 81", "جزاءات 81", "مرتب 81", "مرتب 81-1"))
For i = 1000 To 7 Step -1
If Nam = "" Then Exit Sub
If Sh.Cells(i, 2) = Nam Then
If Msg = vbYes Then
On Error Resume Next
Sh.Rows(i).Delete
Else: Exit Sub
End If
End If
Next
With Sh
LR = .Range("B" & Rows.Count).End(xlUp).Row
For p = 7 To LR
.Range("A" & p) = p - 6
Next
End With
Next
Application.ScreenUpdating = True
End Sub

 

تم تعديل يونيو 24, 2019 بواسطه ابراهيم الحداد

[فتحى ابوالفضل]

الاخ الفاضل الاستاذ/ ابراهيم

هل يمكن الحفاظ على المعادلة الموجودة في الخلية A7 لتقوم بعملها فالخلية a7   مع الخلية c5   لهم وظيفة تحديد عدد الصفوف المطلوبة في الجدول فعند كتابة عدد 100 فيتم انشاء 100 صف و هكذا  فالملاحظ عتد حذف اي اسم من b  تختفي المعادلة و يحدث ترقيم تلقائي في الخلية A  و لكن يتم الغاء المعادلة و بالتالي عند كتابة اي عدد في الخلية c5  فلا تأثير لها

[فتحى ابوالفضل]

مدرسة_عبدالله_حسين_-_Copy.rarالاخ الفاضل / ابراهيم الحداد

 

كل عام و حضرتك بخير

 

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

 

قام بالحذف من شيتات ادخال بيانات 155 و بدلات 155 و استقطاعات 155 وبيانات معلمين بشكل صحيح و لكن حدث الخطأ الموجود بالصور في شيتات نقابات 155 و جزاءات 155و و مرتب       155

 

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

تذكير بالمطلوب

عند حذف اسم معلم من صفحة ادخال البيانات يتم حذف كل البيانات المتعلقة بهذا الاسم في الصفحات التالية

بدلات 155 و نقابات 155 و استقطاعات 155 و جزاءات 155 وبيانات معلمين-1 و بيانات معلمين و مرتب     155 و مرتب 155

 

 

 

 

تم تعديل أغسطس 14, 2019 بواسطه فتحى ابوالفضل

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

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

اخى الكريم فتحى

كل عام و انتم بخير

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

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

تم تعديل أغسطس 14, 2019 بواسطه ابراهيم الحداد

[فتحى ابوالفضل]

كلمة السر    

fathy_100

في كل الصفحات

و اشكر حضرتك على المساعدة و هذا ليس بغريب على حضرتك

 

 

تم تعديل أغسطس 14, 2019 بواسطه فتحى ابوالفضل

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

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

اخى تم عمل تعديل بسيط للكود ليعمل بصورة اسرع و اكفأ

اهم اسباب بطء الكود بعض التنسيقات غير الضرورية الرجا مراجعتها و ازالة ما لا يلزم منها

استبدل الكود السابق بهذا الكود :

Sub DelRows()
Dim Sh As Worksheet, Msg As String
Dim Nam As String
Dim i As Long, x As Long, LR As Long
Application.ScreenUpdating = False
t = Timer
Nam = ActiveCell.Value
Msg = MsgBox("من كافة الشيتات" & " " & Nam & " " & "هل تريد فعلا ازالة السيد / ", vbYesNo)
For Each Sh In Worksheets(Array("ادخال بيانات 155", "بدلات 155", "نقابات 155", "استقطاعات 155", "جزاءات 155", "بيانات معلمين-1", "بيانات معلمين", "مرتب       155", "مرتب 155"))
Sh.Unprotect ("fathy_100")
LR = Sh.Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 7 Step -1
If IsEmpty(Nam) Then Exit Sub
If Sh.Cells(i, 2) = Nam Then
If Msg = vbYes Then
On Error Resume Next
Sh.Rows(i).Delete
End If
End If
Next
j = 7
Do While j <= LR
If Sh.Cells(j, 2) <> "" Then
Sh.Cells(j, 1) = j - 6
End If
j = j + 1
Loop
Sh.Protect
Next
MsgBox Round(Timer - t, 2)
Application.ScreenUpdating = True
End Sub

 

[فتحى ابوالفضل]

 

الأخ الفاضل / ابراهيم الحداد

بارك الله فيك و جعلكم عوناً للجميع

الكود يعمل بكفاءة بدءً من الاسم الثالث 

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

ملحوظة

تم الغاء العمود A  في صفحة مرتب 155 الاخيرة

 

 

 

 

 

15 minutes ago, فتحى ابوالفضل said:

 

 

 

 

 

15 minutes ago, فتحى ابوالفضل said:

 

 

 

تم تعديل أغسطس 15, 2019 بواسطه فتحى ابوالفضل

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

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

اخى الكريم فتحى ابو الفضل

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

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

مع العلم اننى عندما قمت بتجريب الكود مرة اخرى و حدث الخطأ فقمت بإغلاق الملف بدون حفظ و اعدت الكرة مرة اخرى تمت المهمة بنجاح بغرابة شديدة

لهذا اعتذر عن تقديم تفسير مناسب لتلك الظاهرة

لى طلب بسيط ان نمسح من الكود الاوامر الخاصة بالترقيم و استخدام هذه المعادلة بدلا منها كما هى :

=IF(B7="";"";SUBTOTAL(3;$B$7:B7))

ليصبح الكود بعد التعديل كالتالى :

Sub DelRows()
Dim Sh As Worksheet, Msg As String
Dim Nam As String
Dim i As Long, x As Long, LR As Long
Application.ScreenUpdating = False
t = Timer
Nam = ActiveCell.Value
Msg = MsgBox("من كافة الشيتات" & " " & Nam & " " & "هل تريد فعلا ازالة السيد / ", vbYesNo)
For Each Sh In Worksheets(Array("ادخال بيانات 155", "بدلات 155", "نقابات 155", "استقطاعات 155", "جزاءات 155", "بيانات معلمين-1", "بيانات معلمين", "مرتب       155", "مرتب 155"))
Sh.Unprotect ("fathy_100")
LR = Sh.Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 7 Step -1
If IsEmpty(Nam) Then Exit Sub
If Sh.Cells(i, 2) = Nam Then
If Msg = vbYes Then
On Error Resume Next
Sh.Rows(i).Delete
End If
End If
Next
Sh.Protect
Next
MsgBox Round(Timer - t, 2)
Application.ScreenUpdating = True
End Sub

 

تم تعديل أغسطس 16, 2019 بواسطه ابراهيم الحداد