اذهب الي المحتوي

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

الخبراء
  • Content Count

    817
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    3

ابراهيم الحداد last won the day on أبريل 21 2018

ابراهيم الحداد had the most liked content!

السمعه بالموقع

574 Excellent

عن العضو ابراهيم الحداد

  • الإسم الفعلي
    الإســم

البيانات الشخصية

  • Gender (Ar)
    ذكر
  • Job Title
    teacher
  • بلد الإقامة
    Aswan
  • الإهتمامات
    Excel

اخر الزوار

2,981 زياره للملف الشخصي
  1. السلام عليكم ورحمة الله اخى الكريم فتحى ابو الفضل الحقيقة ان الملف كبير جدا و حاولت معرفة سبب الخطأ و هو خطأ واحد ترتب عيه عدة اخطاء فى الشيتات المرتبطة بشيت الخطأ الاول حيث ان الصفين السابع و الثامن الوحيدين المرتبطين بخلية فى الاعمدة الاخيرة ومن المرجح ان هذا هو سبب الخطأ حيث لا توجد اخطاء فى باقى الصفوف مع العلم اننى عندما قمت بتجريب الكود مرة اخرى و حدث الخطأ فقمت بإغلاق الملف بدون حفظ و اعدت الكرة مرة اخرى تمت المهمة بنجاح بغرابة شديدة لهذا اعتذر عن تقديم تفسير مناسب لتلك الظاهرة لى طلب بسيط ان نمسح من الكود الاوامر الخاصة بالترقيم و استخدام هذه المعادلة بدلا منها كما هى : =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
  2. السلام عليكم ورحمة الله اخى تم عمل تعديل بسيط للكود ليعمل بصورة اسرع و اكفأ اهم اسباب بطء الكود بعض التنسيقات غير الضرورية الرجا مراجعتها و ازالة ما لا يلزم منها استبدل الكود السابق بهذا الكود : 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
  3. السلام عليكم ورحمة الله اخى الكريم فتحى كل عام و انتم بخير اثناء العمل على محاولة تصحيح الخطأ نبين ان هناك صفحات محمية بكلمة سر فالرجاء اما ارسال كلمة السر او ارسال نسخة من الملف عير محمية و حبذا لو كان يحتوى على الشيتات المراد العمل عليها فقط
  4. السلام عليكم ورحمة الله جرب هذا الملف ربما يفيدك CombTest.xlsm
  5. الف الف مبروك تستحقها عن جدارة و استحقاق نراك قريبا فى اعلى المراتب ان شاء الله
  6. =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 مع مراعاة ( الفاصلة والفاصلة المنقوطة _حسب اعادادات الجهاز عنكم)
  7. السلام عليكم ورحمة الله تفضل اخى الكريم استخراج الصنف.xlsm
  8. السلام عليكم ورحمة الله استخدم المعادلة التالية =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";"سطح ";"")))
  9. السلام عليكم ورحمة الله تم دمج الكودين السابقين حتى يعملا ككود واحد تم تحديد عمل الكود على 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
  10. السلام عليكم ورحمة الله عذرا لقد تم النسخ خطأ فالكود يعمل لدى بكفاءة و لكن الكود التالى افضل و اسرع 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
  11. السلام عليكم ورحمة الله استخدم الكود التالى بزر مستقل Sub FormatRows() i = 7 x = [C5].Value + 6 Do Until i > x Cells(i, 1) = i - 6 i = i + 1 Loop
  12. السلام عليكم ورحمة الله كل عام و اعضاء المنتدى و الامة العربية و الامة الاسلامية بألف خير
  13. السلام عليكم ورحمة الله استخدم الكود التالى لاحظ الكود سيتغرق تنفيذه حوالى 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
  14. السلام عليكم ورحمة الله اخى الكريم على قبل ان اتوجه بالتهنئة لك اتوجه بالتهنئة للموقع و اعضاء الموقع فالمكسب الاكبر لمنتدانا الحبيب الف الف مليون مبروك .... عن جدارة و استحقاق
  15. السلام عليكم ورحمة الله استخدم هذه الدالة المعرفة 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
×
×
  • اضف...