اذهب الي المحتوي
أوفيسنا

تعديل كود حذف


إذهب إلى أفضل إجابة Solved by فتحى ابوالفضل,

الردود الموصى بها

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

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

ولكن

نظراُ لوجود معادلة في الخلية 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 )

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

رابط هذا التعليق
شارك

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

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

وعند اضافة end sub

فإنه لا يعمل

 

Untitled.png

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

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

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

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

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

 

تم تعديل بواسطه ابراهيم الحداد
رابط هذا التعليق
شارك

  • 2 weeks later...

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

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


رابط هذا التعليق
شارك

  • 1 month later...

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

 

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

 

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

 

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

 

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

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

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

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

 

 

 

 

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

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

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

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

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

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

تم تعديل بواسطه ابراهيم الحداد
رابط هذا التعليق
شارك

كلمة السر    

fathy_100

في كل الصفحات

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

 

 

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

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

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

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

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

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 الاخيرة

 

 

 

346766275_-1.png.865059e405a0b619d64adccda567ee56.png1171123940_.png.a45dc846262e6233414435f4a4bbaf9a.png584641518_.png.f139e4762454400de36e5ef7db2e33b5.png1870267338_155.png.25871a50c8f060bc9d6cadc93491c978.png1248696481_155.png.a3391d5d708e16a970b4fd8c58b9b0cb.png

 

 

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

 

 

 

 

 

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

 

 

 

بيانات المعلمين-1.png

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

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

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

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

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

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

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

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

=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

 

تم تعديل بواسطه ابراهيم الحداد
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information