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

السلام عليكم ورحمة الله اخى الكريم فتحى ابو الفضل الحقيقة ان الملف كبير جدا و حاولت معرفة سبب الخطأ و هو خطأ واحد ترتب عيه عدة اخطاء فى الشيتات المرتبطة بشيت الخطأ الاول حيث ان الصفين السابع و الثامن الوحيدين المرتبطين بخلية فى الاعمدة الاخيرة ومن المرجح ان هذا هو سبب الخطأ حيث لا توجد اخطاء فى باقى الصفوف مع العلم اننى عندما قمت بتجريب الكود مرة اخرى و حدث الخطأ فقمت بإغلاق الملف بدون حفظ و اعدت الكرة مرة اخرى تمت المهمة بنجاح بغرابة شديدة لهذا اعتذر عن تقديم تفسير مناسب لتلك الظاهرة لى طلب بسيط ان نمسح من الكود الاوامر الخاصة بالترقيم و استخدام هذه المعادلة بدلا منها كما هى : =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

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

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

السلام عليكم ورحمة الله جرب هذا الملف ربما يفيدك CombTest.xlsm

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

=COUNTIF($C$5:C5,C5)+VLOOKUP(C5,{"اعدادي",19100;"ثانوي",19200},2,0)-1 السلام عليكم ورحمة الله استخدم المعادلة التالية فى العمود "D" =IF(C5="اعدادي";COUNTIF(C5:$C$5;C5)+19100;IF(C5="ثانوي";COUNTIF(C5:$C$5;C5)+19200;"")) استاذ ابراهيم تكفي هذا المعادلة =COUNTIF($C$5:C5,C5)+VLOOKUP(C5,{"اعدادي",19100;"ثانوي",19200},2,0)-1 مع مراعاة ( الفاصلة والفاصلة المنقوطة _حسب اعادادات الجهاز عنكم)

السلام عليكم ورحمة الله تفضل اخى الكريم استخراج الصنف.xlsm

السلام عليكم ورحمة الله استخدم المعادلة التالية =IF(MID(REPLACE(C2;1;LEN("فاتورة بيع");"");1;3)=" AC";" ابواب ";IF(MID(REPLACE(C2;1;LEN("فاتورة بيع");"");1;3)=" CH";"كابينات";IF(MID(REPLACE(C2;1;LEN("فاتورة بيع");"");1;3)=" YK";"سطح ";"")))

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

السلام عليكم ورحمة الله عذرا لقد تم النسخ خطأ فالكود يعمل لدى بكفاءة و لكن الكود التالى افضل و اسرع 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

السلام عليكم ورحمة الله استخدم الكود التالى بزر مستقل Sub FormatRows() i = 7 x = [C5].Value + 6 Do Until i > x Cells(i, 1) = i - 6 i = i + 1 Loop

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

السلام عليكم ورحمة الله استخدم الكود التالى لاحظ الكود سيتغرق تنفيذه حوالى 5 ثوانى او اكثر Sub SumIfCod() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, i As Long, x Dim Rng As Range, LR As Long, y As Double Set ws = Sheets("الاصناف") Set Sh = Sheets("المبيعات") LR = Sh.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False T = Timer i = 4 Do While ws.Range("A" & i) <> "" x = ws.Range("A" & i).Value y = WorksheetFunction.SumIf(Sh.Range("B2:B" & LR), x, Sh.Range("D2:D" & LR)) ws.Range("G" & i) = y i = i + 1 Loop MsgBox (Timer - T) Application.ScreenUpdating = True End Sub

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

السلام عليكم ورحمة الله استخدم هذه الدالة المعرفة Function Repeat_Int(Rng As Range) For i = 1 To Len(Rng) If IsNumeric(Rng) Then If Mid(Rng, i, 1) = 1 Then p = p + 1 End If End If Next Repeat_Int = p End Function