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

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

السلام عليكم ورحمة الله يجب وضع اسماء الصور فى العمود "B" بجوار الارقام اليك الملف المعلومات المدنية.rar

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

السلام عليكم ورحمة الله و يمكنك ايضا ان تجرب هذا الملف ربما يفيدك توزيع رغبات2.xlsm

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

السلام عليكم ورحمة الله استخدم هذا الكود وخصص له زر Sub TransData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, ShName As String Set Sh = Sheets("Form") ShName = Sh.Range("B9") For Each ws In ThisWorkbook.Worksheets LR = ws.Range("A" & Rows.Count).End(xlUp).Row If ws.Name = ShName Then ws.Range("A" & LR + 1 & ":G" & LR + 1).Value = _ Application.Transpose(Sh.Range("B2:B8").Value) End If Next Application.CutCopyMode = False End Sub ترحيل البيانات من نموذج تسجيل الى جميع الصفحات بإسم الصفحة.xlsm

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