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

السلام عليكم ورحمة الله استخدم هذا الكود وخصص له زر 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

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

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

السلام عليكم ورحمة الله اخى الكريم لقد تم تصميم الشيت على اساس كتابة الغياب فى نفس خلية درجة آخر العام و ليس خلية درجة المجموع و اليك الحل قم باستبدال الداتا فاليداشن او المعروفة بالتحقق من الصحة للتحكم فى الدرجات المدخلة كما يلى حدد عمود آخر العام للمادة ومن التحقق من الصحة اختر Custome ثم اكتب المعادلة التالية فى صندوق Formula مثلا مادة الرياضة العامة : =OR($BA8<=12;$BA8="غ") و فى عمود المجموع ضع المعادلة الآتية ثم اسحب حتى آخر صف وهذه المادلة لمادة الرياضة العامة ايضا : =IF(BA8="غ";"غ";SUM(AY8:BA8)) و يطبق هذا على جميع المواد الاخرى كل فى عموده و بعد ذلك سوف ترى احصيائيات سليمة ومنطقية و الله ولى التوفيق

السلام عليكم ورحمة الله احبتى فى الله اليكم ملف الصف الاول كنترول اولى - ت النهائى 201999.rar

السلام عليكم ورحمة الله اخى الكريم الاهلاوى اشكرك على تنبيهى بالناجحين بالرغم ان لديهم ملاحق فى الدين او التربية الوطنية لذا ارجو من الاخ عمراوى ان ينتبه الى هذا الامر - ارجو المعذرة و بفضل الله قد تم اصلاح الخطأ و كذلك كشف الراسبات اما شيت اولى سوف يتم العمل عليه بعد الافطار باذن الله اليك ملف الصف الثانى حسب آخر التعديلات و يارب النت ميكسفنيش ثانية.xlsm

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

السلام عليكم ورحمة الله كل عام و انتم بخير اخى الكريم بمناسبة الشهر الفضيل و نهاية العام الدراسى اليك ماطلبت باذن الله و اى ملاحظات ستجدنى فى الموعد باذن الله ثانية.rar

السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله كل عام وانتم بخير بمناسبة الشهر الكريم و امتحانات آخر العام اليك الملف بعد التعديل اولى - ت.rar

السلام عليكم ورحمة الله اخى الكريم ناصر كل عام و انتم بخير انا استخدم اوفيس 2016 و الملف فتح عندى بدون مشاكل يؤسفنى عدم القدرة على مساعدتك حقيقة و لا ادرى اين هى المشكلة