سليم حاصبيا

بعد أذن الاخ ابو حنين و اثراءً للموضوع هذا الملف (ربما اسرع قليلاً) تجميع salim.rar

خذ التنسيقات من العامودين I & J الى باقي الاعمدة cond_form.rar

انا لم اضع التنسيق الشرطي الا للقيمة الاعلى فقط لذلك كان طلبي بإعادة التنسيق الشرطي للملف حسبما تريد

السبب هو وجود الماكرو الذي يثقل كاهل الملف (كل الماكروات موجودة في حدث الصفحة) اوقف العمل بها وترى ان كل شيء تمام بالنسبة لتنسيق الخلايا السالبة باللون الاحمر يكفي ان تحدد النطاق اللازم و تذهب الى تنسيق الخلايا و تحدد التنسيق الذي تريد (يجب اعادة التنسيقات كما كانت وانا اعرف ان لك القدرة على ذلك) انظر ماذا حدث بعد توقيف الماكروات cond_format salim.rar

جرب هذا الماكرو Sub filter_me() lre = Cells(Rows.Count, 5).End(3).Row Range("e3:g" & lre).Copy Range("k3") Range("l4:m" & lre).SortSpecial , key1:=Range("m4"), order1:=xlDescending End Sub

استعمل المعادلة التالية للتنسيق الشرطي =(D$26=MAX($D26:$O26))*(COUNTIF($D26:D26,D26)=1)=1

جرب هذا الملف الجديد ربما يكون اسرع قليلاً ترتيب المجموع salim corriger.rar

r = r + k + 3 استبدل الرقم 3 بالرقم 2 قي هذا السطر تأكد من ذلك بوضع بعض البيانات الجديدة في العامود C

جرب هذا الملف ترتيب المجموع salim.rar

انسخ هذه المعادلة الى الخلية F4 واسحب نزولاً =IF($A4<>"",LEFT(SUBSTITUTE(SUBSTITUTE(TRIM($A4)," ","*",3),"الصنف : ",""),FIND("*",SUBSTITUTE(SUBSTITUTE(TRIM($A4)," ","*",3),"الصنف : ",""))-1),"")

يجب ان تزيل التكرار من العامود A , وليس B و ذلك فبل الضفط قبل الزر

يمكن ان يكون المطلوب تنسيق شرطي يلون يوم الجمعة والسبت عمودياً باللون الرمادي salim.rar

ربما هذا ما تريده Stock Book fair -salim avancee.rar

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

جرب هذا الشيء ملف المهام تجربة salim.rar

بعد اذن الاخ ابو حنين هذا الكود ربما يكون اسرع قليلاً Sub transpos_data() Dim Sh_Principal As Worksheet Dim lr As Integer Dim my_row As Integer Set Sh_Principal = Sheets("الرئيسية") Dim My_rg As Range lr = Sh_Principal.Cells(Rows.Count, 1).End(3).Row For I = 3 To Sheets.Count my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row ' Sheets(I).Range("a4:G" & my_row).ClearContents Sh_Principal.Range("a1").AutoFilter field:=1, Criteria1:=Sheets(I).Name Set My_rg = Sh_Principal.Range("a2:g" & lr).SpecialCells(12) my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row If my_row < 4 Then my_row = 4 If my_row = 4 Then My_rg.Copy Destination:=Sheets(I).Range("A4") Else My_rg.Copy Destination:=Sheets(I).Range("A" & my_row + 1) End If Next End Sub

جرب المرفق Stock Book fair -salim.rar

استبدل الكود بهذا Sub exp() Dim My_Sheet As Worksheet Dim Nme, lr, lr1 As String Dim filter_range, rg_to_copy As Range lr1 = Sheets("قوائم ").Cells(Rows.Count, 1).End(3).Row If lr1 < 12 Then lr1 = 12 Sheets("قوائم ").Range("a12:g" & lr1).ClearContents Nme = Sheets("قوائم ").Range("c7").Value lr = Sheets(Nme).Cells(Rows.Count, 1).End(3).Row Set filter_range = Sheets(Nme).Range("a12:g" & lr) On Error Resume Next Sheets(Nme).Range("A12").AutoFilter field:=7, Criteria1:=Sheets("قوائم ").Range("c8") Set rg_to_copy = filter_range.SpecialCells(12) If rg_to_copy.Rows.Count = 1 Then MsgBox "لا توجد هذه الشعبة" & " " & Sheets("قوائم ").Range("c8") & Chr(10) & "في الصف" & " " & Nme, vbExclamation + vbMsgBoxRight: GoTo ending rg_to_copy.Copy Sheets("قوائم ").Select ActiveSheet.Range("a12").PasteSpecial (xlValues) ending: Application.CutCopyMode = False If Sheets(Nme).autofiltrmode = True Then Sheets(Nme).ShowAllData Sheets("قوائم ").Select ActiveSheet.Range("a12").Select 'Sheets(Nme).AutoFilter End Sub

لغاية الان لم اجد حل لهذه المشكلة ربما احد من الزملاء عنده الحل

جرب هذا الكود serch_data salim.rar

جرب هذا الملف Data salim.rar

اليك الملف جاهزاً تم حمابة الخلايا التي تحتوي على معادلات (لعدم العبث بها عن طريق الخطأ) قوائم فصول اليةsalim protect.rar

اذهب الى هذا العنوان http://www.officena.net/ib/topic/71014-معادلة-لجلب-بيانات-الطلاب-لعمل-قوائم-فصول-على-نموذج-واحد/#comment-459797

أولاً كي تعمل المعادلات بشكل صحيح 1-يجب ازالة كل الخلايا المدمجة في المستند(تم عمل ذلك) لان الخلايا المدمجة العدو رقم واحد للمعادلات و الاكواد 2- كتابة اسم المدرسة والشعبة و الخ..... تماماً كما هي في الجدول الاساسي (دون زيادة حرف اونقصان حرف المسافات تحسب) جرب هذا الملف قوائم فصول اليةsalim.rar

تم معالجة الامر Perfet fact final form1.rar