نجوم المشاركات

بفرض أن الملفين في نفس المسار(في نفس الفولدر) 2.xlsm

برنامج أرشفة 1- الملفات والمرفقات والمجلدات 2- البرامج المساعدة ومرفقاتها أرجو ابداء رأيكم به ArchiveMyFiles-Folders.rar

وعليكم السلام تفضل أخي الكريم ولكن أرجو الانتباه إلى أرقام الصفحات يجب أن تمون دائما بالشكل (-12-) عدلت بعضها مثل (-12) أرجو تعديل الباقي أي استفسار انا جاهز kutub202022 (1).xlsm

بعد اذن أخي الكريم @ابو البشر اسمح لي ان اقتنص شكل نموذجك المقترح واكمل عليه المطلوب ...... ملاحظة :::: - يجب تنصيب اخر نسخة من الواتس في الجهاز - يجب تفعيل الامان في بريدك الخاص بالجي ميل - يجب الضغط على الضبط اول مرة فقط لتسجيل بريدك في الجي ميل والباس بعد تفعيل الامان فيه - يجب اولا لارسال رسائل الواتس تشغيل برنامج الواتس ثم الضغط على زر ارسال رسائل الواتس جرب واعلمنا بالنتيجة ............................ مجلد جديد (3).rar

إن شاء الله التقرير.xlsm

بارك الله

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

السلام عليكم 🙂 اذا عندنا تقرير بهذه الطريقة: . اليس الافضل دمج بيانات الحقل المتكررة عموديا في حقل واحد ، مثل الوورد مثلا الى : . طريقة العمل : 1. اعمل تقريرك بالطريقة اللي تراها مناسبة ، بالفرز والتصفية : . او بالمجاميع : . 2. ولكن قم بوضع جميع الحقول في قسم "التفصيل" Detail : . 3. ثم اجعل برواز جميع حقول هذا القسم شفافة . 4. ثم الحقول التي تريد دمجها ، اخفاء المتكرر = نعم ، Hide Duplicates = Yes . 5. ثم ضع هذه الاحداث للتقرير Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) 'Border color not set, use field ForeColor Call Detail_Print_Run_All(5, "'اليوم', 'التاريخ','الزمن'") End Sub Private Sub Report_Open(Cancel As Integer) Call Report_Open_Run(Me.Name) End Sub Private Sub Report_Close() On Error Resume Next Set ctl_ReSize = Nothing End Sub Private Sub Report_Page() Call Report_Page_Run End Sub . 6. لا تحتاج الى عمل اي تغيير في الاحداث اعلاه ، فقط انسخها من هنا والصقها في تقريرك ، ما عدا اول جزء : عرض البرواز ، حيث نخبره باسماء الحقل/الحقول التي نريد دمجها عموديا ، لون البرواز يكون حسب اللون الذي نكتبه ، او اذا لم نكتب لون البرواز ، فلون البرواز سيكون لون نص الكلمات في الحقل . 7. نسخ الوحدة النمطية mod_Report_Field_Hieght_ReSize الى تقريرك ن وكذلك بدون عمل اي تغيير فيها : Option Compare Database Option Explicit Dim rpt_Name_ReSize As String Dim rgb_Border_ReSize As Long, ini_rgb_Border_ReSize As Long Dim Detail_Calc_Height_ReSize As Long Dim Exclude_fld_Name_ReSize As String Dim Add_H_Each_Record_ReSize As Boolean Dim fildMaxHeight_ReSize As Long Dim myDrawWidth As Integer Public ctl_ReSize As Control Dim i_ReSize As Integer, j_ReSize As Integer Dim x_ReSize() As String, tmp_ReSize As String Dim Count_Pages_ReSize As Integer Dim sfld_Name_ReSize() As String, sfld_Value_ReSize() As String, _ sfld_Count_ReSize() As Integer Dim L_ReSize As Single, T_ReSize As Single, W_ReSize As Single, H_ReSize As Single ' Function Detail_Print_Run_All(LineWidth As Integer, myFields As String, Optional border_Color As Long = 1) 'we can this Function in the following ways, indicating Border Color 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", RGB(0, 0, 0)) 'Border color is RGB Value 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", vbBlack) 'Border color is Black 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'", vbMagenta) 'Border color is Magenta 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'") 'Border color not set, use field ForeColor 'Call Detail_Print_Run_All(5,"'b1'", RGB(0, 0, 0)) '5 is Line Width 'we get most the Lines drawn in Detail Section, 'except for the Last Record in each page, where we use Report Page event (the last page is easy) ini_rgb_Border_ReSize = border_Color rgb_Border_ReSize = ini_rgb_Border_ReSize Exclude_fld_Name_ReSize = myFields Add_H_Each_Record_ReSize = False myDrawWidth = LineWidth 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") ReDim Preserve sfld_Name_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Value_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Count_ReSize(UBound(x_ReSize)) '1 'do the Detail Lines for the remaining fields Call Detail_Sec_Max_Height '2 'now work on the special fields Lines For i_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(i_ReSize), "'", ""))) sfld_Name_ReSize(i_ReSize) = tmp_ReSize Call Scale_Box_Lines(tmp_ReSize) Next i_ReSize End Function Function Report_Open_Run(rpt_Name_ReSize_1) rpt_Name_ReSize = rpt_Name_ReSize_1 'Reset the variables from here Count_Pages_ReSize = 0 Erase sfld_Name_ReSize Erase sfld_Value_ReSize Erase sfld_Count_ReSize Detail_Calc_Height_ReSize = 0 End Function Function Report_Page_Run() 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") 'now work on the special fields Lines For j_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(j_ReSize), "'", ""))) sfld_Name_ReSize(j_ReSize) = tmp_ReSize Set ctl_ReSize = Reports(rpt_Name_ReSize)(tmp_ReSize) If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top 'H_ReSize = ctl_ReSize.Height 'we have to add the Sections/Fields ABOVE the Detail Section If Reports(rpt_Name_ReSize).Page = 1 Then H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height + _ Reports(rpt_Name_ReSize).ReportHeader.Height Else H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height End If Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize + H_ReSize)-(L_ReSize + W_ReSize, T_ReSize + H_ReSize), rgb_Border_ReSize 'Bottom Line Next j_ReSize Detail_Calc_Height_ReSize = 0 End Function Public Function Scale_Box_Lines(fld_Name As String) Set ctl_ReSize = Reports(rpt_Name_ReSize)(fld_Name) 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top H_ReSize = ctl_ReSize.Height If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'take the highst Height If fildMaxHeight_ReSize > H_ReSize Then H_ReSize = fildMaxHeight_ReSize End If If ctl_ReSize.Text <> sfld_Value_ReSize(i_ReSize) Then sfld_Value_ReSize(i_ReSize) = ctl_ReSize.Text sfld_Count_ReSize(i_ReSize) = 1 End If 'Box the cells 'Left and Right ctl_ReSize.BorderColor = vbWhite Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize, H_ReSize), rgb_Border_ReSize 'Left Line Reports(rpt_Name_ReSize).Line (L_ReSize + W_ReSize, T_ReSize)-(L_ReSize + W_ReSize, H_ReSize), rgb_Border_ReSize 'Right Line 'Top and Bottom If Reports(rpt_Name_ReSize).Page <> Count_Pages_ReSize Then 'first Count_Pages_ReSize = Count_Pages_ReSize + 1 Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line ElseIf sfld_Count_ReSize(i_ReSize) = 1 Then 'First Record Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line End If sfld_Count_ReSize(i_ReSize) = sfld_Count_ReSize(i_ReSize) + 1 End Function Public Function Detail_Sec_Max_Height() fildMaxHeight_ReSize = 0 'get the max Height For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If ctl_ReSize.Height > fildMaxHeight_ReSize Then fildMaxHeight_ReSize = ctl_ReSize.Height End If Next 'Draw lines around the fields For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If InStr(Exclude_fld_Name_ReSize, "'" & ctl_ReSize.Name & "'") = 0 Then Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (ctl_ReSize.Left, ctl_ReSize.Top)-Step(ctl_ReSize.Width, fildMaxHeight_ReSize), ctl_ReSize.ForeColor, B 'just add the Heighs of ONE Record If Add_H_Each_Record_ReSize = False Then Detail_Calc_Height_ReSize = Detail_Calc_Height_ReSize + fildMaxHeight_ReSize Add_H_Each_Record_ReSize = True End If End If Next End Function . 8. ما عدا هذا الجزء ، والذي يجب ان نضع فيه اسماء جميع الاقسام التي فوق "قسم التفصيل" ، والتي بها ارتفاع : . من هنا نعرف اسم هذه الاقسام : . وهذه نتائج بعض التقارير التي تم النجربة عليها : . . . . ولم اتوصل لطريقة لجعل الكلمات في منتصف الحقل عموديا ، هكذا: جعفر Report_BoxLine_07.accdb.zip

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

البرنامج لارشفة السجلات وحفط المستندات يحقظ المستندات داخل البرنامج بدون مسار للمحفوظات يمكن نقل البرنامج لائي برتشن او مجلد او اي جهاز دون فقد المحفوظات المحفوظات.accdb

🤐

ابحث عن السطر الموجود في الصورة واوقف عمله بوضع الفاصلة كما في الصورة ثم شغل البرنامج وارسل رسالة البريد ثم اذهب الى المجلد الموجود بجوار البرنامج والمسمى بالشهادات هل فيها ملف PDF ؟؟؟

امين واياك ... هل فكيت الضغط عند الملف والمجلد ....

شكرا لك أخي العزيز @kkhalifa1960 جهد رائع وعمل تشكر عليه وجعله الله في ميزان حسناتك 🙂 ومثل ما قال أخي @TQTHAMI البرنامج إبداع ولكنه مزحوم جدا .. يحتاج إلى تبسيط من ناحية تقسيم الخدمات اللي يوفرها أوالألوان والأشكال والخطوط المتداخلة .. وحبذا مع شرح مبسط لكيفية الاستخدام 😊

لا اعلم لماذا مايكروسوفت لم تضع هذا الكود البرمجي ضمن جميع النسخ ...بحيث لا يحتاج المبرمج ان يكتب هذا الكود ؟

استدل السطر كاملا بهذا .................. #If VBA7 Then Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long #Else Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long #End If

لانك تستخدم نسخة 64 ضع ptrsafe بعد ال Declare

تفضل أخي بدون مسافة "" بينهم d=[a]& "" & [b]

السلام عليكم ورحمه الله وبركاته مشاركه مع الاستاذ @kkhalifa1960 جزاه الله خيرا وعلى قد فهمى المرفق الاول حسب الطلب فى اول المنشور انظر الاستعلام 551 المرفق الثانى على حسب تعديلاتك للاستعلام الجدولى انظر الاستعلام qryTotal ان شاء الله يكون ما تريد تقبلوا تحياتى وبالتوفيق طلب المساعدة_1.accdb طلب المساعدة_2.accdb

الف مليون شكرا لحضرتك @Eng.Qassim انا كنت حليت المشكلة بعمل نموذج فرعي ياخد القيمة منه مباشرة جزاك الله خير ده مشروع خيري وفي مشكلة ثانية سوف ارفقها فس سوال جديد والف شكرا لكرمك

تابع الموضوع اعلاه .............

السلام عليكم ورحمة الله وبركاتة ماشاء الله قمة في في الابداع عمل رائع ومجهود جبار لكن عندي ملاحظة وهي : 1- كثرة الالوان 2- الخط صغير هل تسمح لي بتغير الشكل وانزالة مرة اخرى

1- لان الأرقام غير موجودة بالاساس

طيب جرب الان بالنسبة للخطأ الحاصل MO.rar

السلام عليكم و رحمة الله و بركاته الاخ الاستاذ @محي الدين ابو البشر الكود بعد التعديل يعمل جيدا و جزاك الله الجنة استفسار 1. لماذ لا يظهر الرقم المتسلسل حسب الاسم يعني من 1-10 و الصفحة التي تليها 11-20 و حسب اعداد الطلبة 2. اذا ممكن كود مسح النموذج الاستقبال بيانات جديد ( كود مسح ) و اعتذر منك و شكرا جزيلا لك و بارك الله في علمك و في ميزان حسناتك

اخي وليد المصرى 1 اسف علي التأخير تفضل تطابق ارقام.xlsm هذا الكود المستخدم Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim m As Integer m = 7 Do While Cells(m, "b") & Cells(m, "h") <> "" If Cells(m, "b") & Cells(m, "h") >= 1 Then Application.ScreenUpdating = False ' Cells(m, "g") = _ "=IF(RC[-5]&RC[1]="""",""No "",IF(RC[-5]-RC[1],""Can Extension"",""DONE""))" Cells(m, "g") = Cells(m, "g").Value Else Cells(m, "K") = "" End If m = m + 1 Loop Application.ScreenUpdating = True End Sub

الحمدلله الذي تتم بنعمته الصالحات

تفضل اخي الكريم بالتوفيق Database2.accdb

السلام عليكم بالنسبة للسؤال الاول / اعمل مجلد بجانب قاعدة البيانات للصور يكون مسارها حسب كل سجل وهكذا لاتتضخم قاعدة البيانات ويوجد بالموقع الكثير من الامثلة عن ذلك بالنسبة للسؤال الثاني / حسب فهمي للموضوع انه كل صورة خاصة بموظف معين يجب ان تاخذ مسار معين بالملف (مجرد تديد الصورة من قاعدة البيانات ) تحياتي

فقط استبدل بالكود القديم Sub Test() Dim a, b, x Dim i, ii Dim nmsht, dt, bk Dim p As Long Dim ar As Long Dim tmp, class, br, mat Const c As Integer = 25 Set nmsht = Sheets("name") Set dt = Sheets("data") Set bk = Sheets("Book") b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3) p = 4: For i = 1 To UBound(b) tmp = Split(b(i, 1)) class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2)) br = tmp(UBound(tmp)): mat = b(i, 3) With nmsht.Range("b2:AX400") x = .Find(b(i, 1), , , 1).Address a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1) End With ar = 1 With Sheets("book") For ii = 1 To UBound(a) Step c x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2) .Cells(x - 6 - c, 4) = .Cells(x - 6 - c, 4) & " " & class .Cells(x - 6 - c, 9) = .Cells(x - 6 - c, 9) & " " & br .Cells(x - 6 - c, 15) = mat zzZ = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "") For i = 1 To 10 .Cells(x - 1 - c, 2 + m) = Z(i, 2) mm = mm + 4 Next ar = ar + c p = p + 2 Next End With Next End Sub

عادة الخلايا المدموجة والأكواد لا يتفقان لذلك.....!!

😀

ممكن يكون هذ هو المطلوب معاينة طباعة مع امكانية الطباعه.xls

تم التصحيح لا بد أن يكون نوع/تنسيق الخلية في الجدولين متساوي ، عليه حولت لك النوع في صفحة البحث من نصي إلى رقمي باستخدام دالة Value Filename_02.xlsx

ابشر تم .. 😘 مقارنة.xls

تشكر أخي @ابو جودي ولكن لي سؤال :::: ماذا لو قام العميل بشراء اكثر من برنامج من قبل المبرمج .... الأ تعتقد في هذه الحالة تشابه المفتاح في كل البرامج ..... اذن ::: نحتاج الى رقم اضافة رقم لكل برنامج بالاضافة الى ما تم ذكره حتى نضمن عدم تشابه هذه المفاتيح على جهاز واحد ؟؟؟؟؟ مجرد رأي ...

السلام عليكم ورحمة الله وبركاته نبارك للجميع النسخة الجديدة للموقع الرائع ونسال الله سبحانه وتعالى ان ينعم عليكم بالصحة والعافية اعتذر لانقطاعي وتواصلي بالموقع للفترة الماضية لظروف خارجة عن ارادتي اساتذتنا الكرام في المرفق هناك ورقة رئيسية فيها اسماء وارقام المطلوب البحث باوراق اخرىحسب المواد عن هذه الارقام اذا كان موجود نكتب الرقم 1 تحت كل مادة والا تبقى فارغة ودعواتي للجميع بدوام الصحة والعافية نتائج.rar

السلام عليكم ورحمة الله وبركاته الاساتذة الكرام والاخوة الاعزاء جزاكم الله خيرا بعد ان انقطعت اخبار اخينا وحبيبنا ابو انس حاجب حفظه الله ورعاه واعطاه الصحة والعافية ارسلت الى الاخ الحبيب ابو انس حاجب رسالة على الخاص منذ زمن ليس بالقليل والان جاء الجواب والحمد لله هو بخير وعافية ولكن يحتاج الى دعواتنا فنسال الله سبحانه وتعالى ان يحفظه من كل سوء ويجعل اموره الى خير ويبارك له في صحته وعافيته ويقضي حاجته بخير وعافية ويرزقه خير الدنيا وخير الاخره ويكفيه ما اهمه ويفرج عنه فرجا قريبا بحول الله تعالى وقوته فانه لاحول ولاقوة الا بالله العظيم وهذه هي رسالة اخي وحبيبي ابو انس حاجب (بعد الحمد والشكر لله فأنا في نعمة وصحة جيدة سبب أنقطاعي أنني عدت إلى اليمن في محاولة للأستقرار ولكني لم أوفق حتى الآن في ترتيب وضعي ولربما سوف أعود إلى الصين للعمل هنالك من جديد حالياً الحالة النفسية والعامة لدي تمنعني من التواصل دعائكم لي بالتوفيق لما فيه خير لي في الدنيا والآخرة إلى لقاء قريب بحول الله وقوته أبو أنس)

اللهم إنى عبدك إبن عبدك إبن أمتك ناصيتى بيدك .... ماض فى حكمك عدل فى قضاؤك اللهم انى أسألك بكل إسم هو لك سميت به نفسك أو أنزلته فى كتابك أو علمته أحدا من خلقك .... أو إستأثرت به فى العلم الغيب عندك أن تجعل القرآن العظيم ربيع قلبى ونور صدرى وجلاء حزنى وذهاب همى وغمى الحمدلله رب العالمين وأفضل الصلاة وأتم التسليم على سيدنا محمد وعلى اله وصحبه وسلم أستغفر الله العظيم الذي لاله الاهو الحي القيوم وأتوب اليه اللهم ياجامع الشتات ويامخرج النبات ويامحيي العظام الرفات ويامجيب الدعوات وياقاضي الحاجات ويامفرج الكربات وياسامع الاصوات من فوق سبع سموات ويافاتح خزائن الكرامات ويامالك حوائج جميع المخلوقات ويامن ملىء نوره السموات ويامن أحاط بكل شي علما واحصى كل شي عدداً وياعالماً بما مضى وماهو آت اسألك اللهم بقدرتك على كل شي وباستغنائك عن جميع خلقك وبحمدك ومجدك يآ إله كل شي واسألك اللهم ان تجود علي " أخينا أبوأنس حاجب " بقضاء حاجتة انك قادرعلى كل شي يارب العالمين ياعظيم يرجى لكل عظيم ياعليما انت بحالنا عليم

اسأل الله ان يفرج همنا وهمك ويرفع عنك كل بلاء, شدة وتزول اخي الكريم ....... عرفته يمنياً في تلفته خوفٌ...وعيناه تاريخ من الرمدِ من خضرة القات في عينيه اسئلة...صفر تبوح كعودٍ نصف متقدِ

السلام عليكم ورحمة الله وبركاته الاخوة الاعزاء والاساتذة الكرام جزاكم الله خيرا ارجو ابداء المساعدة لغرض ترحيل الطلبة المنقولين من ورقة ( الاسماء حسب الفصول) , ترحيلهم ومسح بياناتهم الى ورقة المنقولين من المدرسة والشرط وضعته في العمود ( U ) في ورقة ( الاسماء حسب الفصول) وهو كلمة ( نقل) فكل طالب امام اسمه كلمة نقل ترحيل بياناته وتمسح نهائيا من ورقة (الاسماء حسب الفصول ) دون ان تمسح المعادلات الموجودة في ورقة (الاسماء حسب الفصول )علما بان الفصول تحت بعض لكن بفاصل لكل 50 طالب اثابكم الله وزادكم من فضله علما وخيرا كثيرا تقبلوا فائق احترامي وتقديري قوائم المدرسة.rar

السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة تقبلوا تحياتي وشكري

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل والعالم العلامة عبد الله باقشير حفظكم الله سبحانه وتعالى وانعم عليكم بالصحة وتمام العافية ورزقكم خير الدنيا وخير الاخرة اعمالكم فخر لنا وللوطن العربي زادك الله من فضله علما وخيرا كثيرا اكرمكم الله في الدارين واعلى مقامكم واعزكم وكل الشكر والاحترام والتقدير للاستاذ الكبير ابو حنين عافاه الله واعطاه خير الدنيا والاخرة تقبلوا فائق احترامي وتقديري

السلام عليكم بعد اذن اخي الحبيب ابو حنين هذا الكود اعددته مع المسح والفرز للجداول يجب تنفيذ الكود من الورقة (الاسماء حسب القصول) Sub kh_trheel() Dim cel As Range Dim Lr As Long, Lrr As Long, R As Long, i As Long, iCont As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Lrr = Cells(Rows.Count, "C").End(xlUp).Row With Sheets("المنقولين من المدرسة") Lr = .Cells(Rows.Count, "B").End(xlUp).Row iCont = WorksheetFunction.Max(.Range("A5").Resize(Lr)) For R = 5 To Lrr If Cells(R, "U").Value = "نقل" Then i = i + 1 .Cells(Lr + i, "A").Value = iCont + i .Cells(Lr + i, "B").Resize(1, 8).Value = Cells(R, "B").Resize(1, 8).Value If cel Is Nothing Then Set cel = Cells(R, "A").Resize(1, 23) Else Set cel = Union(cel, Cells(R, "A").Resize(1, 23)) End If Next End With If i Then On Error Resume Next cel.SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 For R = 5 To Lrr Step 53 With Cells(R, "A").Resize(50, 23) .Sort .Columns(3), xlAscending End With Next End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Set cel = Nothing End Sub تحياتي

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

السلام عليكم استعمل هذا الكود Sub sCopy_To() Application.ScreenUpdating = False lr = Sheets("الاسماء حسب القصول").Cells(Rows.Count, "C").End(xlUp).Row + 1 x = 5 For i = 1 To lr If Sheets("الاسماء حسب القصول").Cells(i, 21) = "نقل" Then Sheets("الاسماء حسب القصول").Range("B" & i).Resize(1, 9).Copy With Sheets("المنقولين من المدرسة") .Range("B" & x).PasteSpecial xlPasteValues .Range("A" & x) = x - 4 End With x = x + 1 End If Next Application.ScreenUpdating = True Application.CutCopyMode = False End Sub

أخى الغالى والعزيز أنا أسف رغم إنشغالى الشديد وعدم تركيزى ودخولى إلى المنتدى بشكل مفاجئ للأطلاع فقط إلا إنى لم أستطع أن أرى حضرتك فى حاجة إلى شئ وأخرج دون تلبية طلبك فى شكل محاولة لاأدرى إن كانت المطلوبة أم لا ولاطبع أتمنى من كل قلبى أن تحقق طلبك رغم عدم التركيز إحتساب غائب.rar

أخي الحبيب ( عباس) أولاشكرا علي كلماتك الرقيقة التي تفوقني بكثير ثانيا الحمد لله والشكرلله أن المعادلة حققت طلبك وهذا هو الهدف الأساسي ثانيا - ليه حضرتك نزلت شرط الكسر الأقل من ال( .5 ) إلي الرقم الصحيح وهو الصفر لأن بكده كل الأقل من النصف يتساوي ( أويرفع ) مثلة مثل الأكبر من أو يساوي النصف لأن المعادلة : أللي بتحقق الشرط الأخير هي: =IF(OR(L24<>"";M24<>"");IF(ABS(SUM(L24:M24))/2-INT(SUM(L24:M24)/2)>=.5;INT(SUM(L24:M24)/2)+1;SUM(L24:M24)/2);"")

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل محمود زادك الله علما ومعرفة وبارك الله في رزقك المعادلة رائعة وهي التي تتخلص من الكسور العشرية لكل متوسط حسابي وفي النهاية يصبح الناتج صحيحا 100% وانا اكملت معادلة المتوسط الحسابي للخلايا (L)حسب معرفتي المتواضعة ارجو مراجعتها اذا كان في المعادلة خطأ ام لا. اخي الحبيب , المشكلة في معادلة AVERAGE تبقي على الكسور العشرية وهي التي تحدث المشكلة في النهاية واستمحيك عذرا كون طلباتي كانت كثيرة ولكن كما تعلم اخي الحبيب هذه حقوق الطلبة ونحن نريد ان نحافظ على استحقاقاتهم بالكامل واحيانا الدرجة يتوقف عليها مصير الطالب بارك الله فيك وحفظك ورعاك ورزقك من حيث تحتسب ومن حيث لاتحتسب والسلام عليكم ورحمة الله وبركاته تعديل معادلة المتوسط الحسابي .rar

أخي الحبيب ( عباس ) أنطر المرفق ستجد أن الحسابات مظبوطة وهناك معادلة ( average ) يمكن تطبيقها مباشرة دون هذه اللفة بالأضافة ألي أن الحل بالطريقتين أعطي نفس النتيجة جبر الكسر في المتوسط الحسابي .rar