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

السلام عليكم ورحمة الله انسخ هذا الكود و الصقه فى موديول و خصص له زر كما يلى : من قائمة insert ---------- Devolper ثم اضغط على زر من القائمة المنسدلة ورابطه بالكود السابق كما ارجو ان تقوم بازالة التنسيق الشرطى كى ترى الدوائر Sub Circles() Dim ws As Worksheet Dim Arr() As Variant Dim LR As Long, R As Long, i As Long Dim Cel As Range Set ws = Sheets("شيت") If LR < 14 Then LR = 14 LR = ws.Range("C" & Rows.Count).End(xlUp).Row Arr = Array(10, 11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37) For R = 14 To LR For i = LBound(Arr) To UBound(Arr) For Each Cel In ws.Cells(R, Arr(i)) If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height) xx.Fill.Visible = msoFalse xx.Line.ForeColor.SchemeColor = 10 xx.Line.Weight = 1.2 End If Next Next Next End Sub

بارك الله فيك استاذنا الكبير متألق كالعادة لا حرمنا الله من ابداعاتك

السلام عليكم ورحمة الله اخى الكريم معذرة على تسرعى استبدل تلك العبارة ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row ).ClearContents بتلك العبارة ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents اعلم ان الفرق بسيط و لكنى لا اريد تشتيت تفكيرك فالفرق هو + 9 و تأكد ان هذا الامر لن يحدث ثانية باذن الله هذا وبالله التوفيق

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

السلام عليكم ورحمة الله انسخ هذا الكود والصقه بموديول جديد واربطه بالزر الموجود بالملف Sub CallingData() Dim data As Worksheet, ws As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set data = Sheets("السجل الكلي") Set ws = Sheets("السجل المطلوب") ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row).ClearContents Arr = data.Range("D9:R" & data.Range("D" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 2) = ws.Range("Q2") Then p = p + 1 For j = 1 To 14 Temp(p, j) = Arr(i, Choose(j, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)) Next End If Next If p > 0 Then ws.Range("D9").Resize(p, UBound(Temp, 2)).Value = Temp If p > 0 Then ws.Range("C9") = 1: ws.Range("C9").Resize(p).DataSeries Step:=1 End Sub

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

السلام عليكم ورحمة الله استخدم دالة Vlookup

السلام عليكم ورحمة الله اخى الكريم الاستاذ سليم تعليقك رائع وفعلا فى محله بارك الله فيك

السلام عليكم ورحمة الله جرب ان تضع هذا الكود فى حدث الصفحة Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 6 Then Exit Sub Dim LR As Long, R As Integer, x As Integer lngLstRow = ActiveSheet.UsedRange.Rows.Count For R = 6 To lngLstRow Step 30 If True Then x = x + 1 Cells(R, "F").Value = x End If Next End Sub

السلام عليكم ورحمة الله اخى الحبيب الملف لدى يعمل بكفاءة تامة احب ان اوضح لك اساس العمل مبنى على الرقم الادارى للموظف بالشيت الاول وليس اسم الموظف يعنى يجب ان تقوم اولا بكتابة الرقم الادارى فى العمود "C"

السلام عليكم ورحمة الله تم التصحيح Emp.rar

السلام عليكم ورحمة الله تفضل Emp.rar

السلام عليكم ورحمة الله استبدل المعادلات السابقة بالمعادلة الآتية =IF(ISNUMBER(AR5)=FALSE;MAX($A$5:$A$9988)-COUNTIF($AR5:$AR$9988;"غ")+1;RANK(AR5;$AR$5:$AR$253;0)+COUNTIF($AR$5:AR5;AR5)-1)

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية " E3 " =LOOKUP(2;1/(متابعة!$B$3:$B$7=C3);متابعة!$C$3:$C$7) ثم اسحب نزولا

السلام عليكم ورحمة الله استبدل هذه المعادلة =IF(ISNUMBER(AR5)=FALSE;MAX($A$5:$A$9988)-MIN($A$5:$A$9988)+COUNTIF($AR$5:AR5;AR5);RANK(AR5;$AR$5:$AR$253;0)) بهذه المعادلة =IF(ISNUMBER(AR5)=FALSE;MAX($A$5:$A$9988)-MIN($A$5:$A$9988)+COUNTIF($AR$5:AR5;AR5)-1;RANK(AR5;$AR$5:$AR$253;0)+COUNTIF($AR$5:AR5;AR5)-1) ثم اسحب نزولا حتى آخر خلية تريدها

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

السلام عليكم ورحمة الله تفضل تجميع الأوراق في ورقة واحدة.rar

السلام عليكم ورحمة الله تم الحل بطريقة مختلفة اليك الملف تجميع الأوراق في ورقة واحدة.rar

السلام عليكم ورحمة الله اخى الكريم تم عمل المطلوب ما عدا فرز وترتيب الاعمدة بسبب دمج الخلايا اليك الملف New Microsoft Excel Worksheet.rar

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

اخى الكريم الاستاذ ناصر السلام عليكم ورحمة الله اليك شرح الكود كما طلبت عسى الله ان اكون قد وفقت وفقنا الله واياكم لما يحب ويرضى Sub LClasses() الاعلان عن المتغيرات ' Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant, Temp2 As Variant Dim LR As Long, i As Long, j As Long, f As Long, p As Long, q As Long Dim x, y, a, b, c, d, xx, yy Dim c1, c2, c3, c4 Dim d1, d2, d3, d4 Set ws = ThisWorkbook.Sheets("بيانات الطلبة") تعريف الشيت الاول وهو مصدر البيانت' Set sh = ThisWorkbook.Sheets("كشوف المناداة") تعريف الشيت الثانى قوائم اللجان' LR = ws.Range("E" & Rows.Count).End(xlUp).Row + 6 آخر صف فى الشيت الاول' Arr = ws.Range("A7:P" & LR).Value تحديد نطاق المصفوفة المصدر' ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) اعادة تعين المصفوفة الثانية الخاصة بكشف اللجان الاول' ReDim Temp2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) عادة تعين المصفوفة الثانية الخاصة بكشف اللجان الثانى' sh.Range("B9:N34").ClearContents مسح اللجان قبل تفريغ اى بيانات جديدة' a = sh.Range("D7").Value رقم اللجنة الاولى' b = sh.Range("L7").Value رقم اللجنة الثانية ' On Error Resume Next c = WorksheetFunction.VLookup(a, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0) التأكد من عدد اللجان للقائمة الاولى' d = WorksheetFunction.VLookup(b, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0) التأكد من عدد اللجان للقائمة االثانية'' x = (a - 1) * c + 1: xx = a * c التعرف على اول و آخر طالب فى الكشف الاول' y = (b - 1) * d + 1: yy = b * d التعرف على اول و آخر طالب فى الكشف االثانى' 0 For i = 1 To UBound(Arr, 1) تنبيه الكود بالصفوف التى سوف يتم العمل عليها فى المصفوفة الام' If i >= x And i <= xx Then شرط الصفوف المطلوبة من المصفوفة الام لكل لجنة ' p = p + 1 العد حسب الشرط الموضح بعاليه' For j = 1 To 4 عدد الاعمدة المطلوبة من المصفوفة الام للمصفوفة الجديدة والتى تخص اللجنة الاولى ( التى هى على يمين الورقة )' Temp(p, j) = Arr(i, Choose(j, 2, 5, 15, 16)) تحديد المصفوفة الجديد او المطلوبة واختيار اعمد بعينها ' sh.Cells(p + 8, 2) = p ترقيم الطلاب فى اللجنة ' Next End If If i >= y And i <= yy Then الشرط الثانى وهو الذى يخص اللجنة الثانية - باقى الشرح نفس الشرح السابق' q = q + 1 For f = 1 To 4 ' Temp2(q, f) = Arr(i, Choose(f, 2, 5, 15, 16)) Cells(q + 8, 10) = q ' Next End If Next If p > 0 Then sh.Range("C9").Resize(p, j).Value = Temp اتصدير المصفوفة الجديدة الاولى كما رتب لها' If q > 0 Then sh.Range("K9").Resize(q, f).Value = Temp2 اتصدير المصفوفة الجديدة الثانية كما رتب لها' الخطوات بالاسفل اعتقد انها واضحة تماما وهى احصيات ''' c1 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسلم" & "*") c2 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسيحى" & "*") c3 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "منقول" & "*") c4 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "باق" & "*") d1 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسلم" & "*") d2 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسيحى" & "*") d3 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "منقول" & "*") d4 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "باق" & "*") خلايا نتائج الاحصائيات''' sh.Range("F3") = c sh.Range("F6") = c1 sh.Range("F7") = c2 sh.Range("F4") = c3 sh.Range("F5") = c4 sh.Range("N3") = d sh.Range("N6") = d1 sh.Range("N7") = d2 sh.Range("N4") = d3 sh.Range("N5") = d4 End Sub

السلام عليكم ورحمة الله استبدل هذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value Then بهذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then واستبدل هذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then

السلام عليكم ورحمة الله بفرض انك خصصت الخلية "F3" لرقم الفاتورة يمكنك تغيير مكان الخلية كما تشاء انسخ هذا الكود والصقه فى حدث "ThisWorkBook" Private Sub Workbook_Open() Dim InvName As String InvName = Left(ActiveWorkbook.Name, 3) Sheet1.Range("F3") = InvName End Sub

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

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