سليم حاصبيا

جرب هذا الملف تحديد النطاق.rar

جرب هذه المعادلات في الخلايا C3: =DATEDIF($A3,$B3,"y") E3: =DATEDIF($A3,$B3,"ym") G3: =DATEDIF($A3,$B3,"md")

اذا لاحظت كيف يعمل الكود فإنك ستفهمه جيدأ يقوم الكود بمقارنة المعدل بالمواد العلمية مع المعدل بالمواد الادبية لكل طالب على حده اذا كان المعدل بالمواد العلمية(MyoenS) اكبر او يساوي المعدل بالمواد الادبية(MyoenA)يسجل الطالب في الورقة العلمية و اذا كان العكس يسجل الطالب في الورقة الادبية و في اخر عامودين من كل ورقة ادرحت لك المعدلين فقط لتعرف ان المقارنة صحيحة و لتتأكد أكثر جرب ان تغير علامات أي طالب يدوياً(فقط بالمواد العلمية و الادبية) لنقله من شعبة الى اخرى و نفذ الماكرو و ترى النتيجة في ورقة العلمي ليست مدرجة كل الاسماء كما تتخيل (يمكنك ملاحظة ذلك من عدد الطلاب الاجمالي) فقط الذين معدلهم العلمي أكبر و هذا ما تريده انت.

جرب هذا الملف المواد العلمية من العامود G trought J المواد الادبية من العامود K throught M توزيع الطلاب علمي أو أدبي Salim.rar

ما هي برأيك المواد العلمية او الادبية (مثلاً القرآن الكريم كيف تصنفه والمجمع ايضاً) اضف عامودين للملف( واحد للمواد العلمبة والاخر للادبية)

يمكنك الاستعانة بهذا الملف D_M_Y.rar يمكنك الاستعانة بهذا الملف

بواسطة تنسيق الخلايا

جرب هذا التعديل على الماكرو Option Explicit Sub give_data1() Dim i, r, k, My_row As Integer Dim My_rg As Range Dim My_Sh As Worksheet Dim S1, S2 As String Application.ScreenUpdating = False For i = Sheets.Count To 2 Step -1 Application.DisplayAlerts = False Sheets(i).Delete Next Application.DisplayAlerts = True For i = 6 To 36 If Main.Range("a" & i) = "" Then Exit For On Error Resume Next S1 = Main.Range("a" & i).Value S2 = Sheets(S1).Name If S1 <> S2 Then Sheets.Add After:=Sheets(Sheets.Count) With ActiveSheet .Name = Main.Range("a" & i) With .Range("a1:d1") .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري") .Interior.ColorIndex = 6 .Range("e2") = "مواد تستهلك الفطور الصباح" End With End With On Error GoTo 0 End If Next Main.Select For i = 6 To 36 r = 2 Set My_rg = Main.Range("a5:cx5") Set My_Sh = Sheets(Main.Range("a" & i) & "") For k = 2 To My_rg.Count If k = 10 Or k = 21 Or k = 67 Then My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row My_Sh.Rows(My_row + 1).Insert Shift:=xlDown: r = My_row + 2 Select Case k Case 10 My_Sh.Range("e" & My_row + 2) = "مواد تستهلك في العشاء فقط" Case 21 My_Sh.Range("e" & My_row + 2) = " مواد تستهلك في الغداء فقط" Case 67 My_Sh.Range("e" & My_row + 2) = "مواد مشتركة بين الغداء والعشاء" End Select End If If Main.Cells(i, k) <> "" Then With My_Sh .Cells(r, 1) = Main.Cells(i, k) .Cells(r, 2) = My_rg.Cells(k) .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0) .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0) .Columns.AutoFit End With r = r + 1 End If Next Next Application.ScreenUpdating = True End Sub

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

جرب هذا الشيء كتابة اعمدة بدلا من الصفر salim.rar

ارفع جزءاً من الملف للمعالجة(بضعة اسطر)

جرب هذا الملف كنموذج tar7im.rar

هتاك عدة معادلات لعمل هذا مثلاً =SUMPRODUCT(--($B$2:$B$18<=$E$3),--($B$2:$B$18>=$E$2),($C$2:$C$18)) =SUMIFS($C$2:$C$18,$B$2:$B$18,"<="&$E$3,$B$2:$B$18,">="&$E$2) =SUMPRODUCT(($B$2:$B$18<=$E$3)*($B$2:$B$18>=$E$2)*($C$2:$C$18))

يجب ان تكون الارقام قي عامود مستقل مثلاً في الخلية A2 النص( قلم رصاص عدد ) يقابلها قي الخلية B2 الرقم 1

تم التعديل بحيث تستطيع الكتابة ايضاً احضار بيانات اليا salim1.rar

باركالله بك اخي ياسر و انا بدوري اقترح هذا الكود ربما يكون اسرع قليلاً Option Explicit Option Base 1 Sub Rand() Dim r, c, i, k As Integer For k = 1 To 11 Step 2 Dim g(34) Do c = Application.RandBetween(1, 34) If Not g(c) Then r = r + 1 Cells(i + 39, k) = c: Cells(i + 39, k + 1) = Range("b" & c) i = i + 1 g(c) = True End If Loop Until r = 14 r = 0: i = 0 Erase g Next End Sub

ربما كان المطلوب احضار بيانات اليا salim.rar

جرب هذا الماكرو الملف مرفق Option Explicit Sub Tirage_Aleatoire_N_Valeurs_Dans_Liste() Dim SL, ar, i, NB, Lr, k With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With NB = 15 ' ' العدد المطلوب ناقص 1 Lr = 34 For k = 1 To 11 Step 2 ar = Range("A2:a" & Lr) If Not IsNumeric(NB) Or NB > Lr Or NB < 0 Then NB = Lr - 1 Set SL = CreateObject("System.Collections.SortedList") Randomize For i = 1 To NB If Not SL.containsvalue(ar(i, 1)) Then SL.Add Rnd, ar(i, 1) Next i With ActiveSheet For i = 0 To Application.Min(SL.Count - 1, NB) - 1 .Cells(i + 39, k).Value = SL.GetByIndex(i) Next End With Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub المصنف1 Salim.rar

جرب هذا الكود Option Explicit Sub give_data() Dim i, r, k As Integer Dim My_rg As Range Dim My_Sh As Worksheet Dim S1, S2 As String Application.ScreenUpdating = False For i = Sheets.Count To 2 Step -1 Application.DisplayAlerts = False Sheets(i).Delete Next Application.DisplayAlerts = True For i = 6 To 36 If Main.Range("a" & i) = "" Then Exit For On Error Resume Next S1 = Main.Range("a" & i).Value S2 = Sheets(S1).Name If S1 <> S2 Then Sheets.Add After:=Sheets(Sheets.Count) With ActiveSheet .Name = Main.Range("a" & i) With .Range("a1:d1") .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري") .Interior.ColorIndex = 6 End With End With On Error GoTo 0 End If Next Main.Select For i = 6 To 36 r = 2 Set My_rg = Main.Range("a5:cx5") Set My_Sh = Sheets(Main.Range("a" & i) & "") For k = 2 To My_rg.Count If Main.Cells(i, k) <> "" Then With My_Sh .Cells(r, 1) = Main.Cells(i, k) .Cells(r, 2) = My_rg.Cells(k) .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0) .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0) .Columns.AutoFit End With r = r + 1 End If Next Next Application.ScreenUpdating = True End Sub الملف مرفق Classeur2 Salim.rar

استبدل الكود بهذا Option Explicit Sub Give_Data() Dim My_Sh As Worksheet Dim My_Rg, cel As Range Dim My_Adr As String Dim k, x As Integer With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Sheets("teachers").Range("c6:g15").ClearContents k = Sheets.Count - 1 For x = 2 To k Set My_Sh = Sheets(x) Set My_Rg = My_Sh.Range("c6:g15") For Each cel In My_Rg.Cells If cel = Sheets("teachers").Range("d2") Then My_Adr = cel.Address With Sheets("teachers").Range(My_Adr) .Value = Mid(Trim(My_Sh.Range("d2")), 5, 10) .Offset(-1, 0) = cel.Offset(-1, 0) End With End If Next Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub

ربما كان هذا المطلوب يمكنك زيادة عدد الشيتات كما تشاء(نفس التنسيق بالنسبة للنطاقات شرط ان تبقى الشيت teachers هي الاولى) ترحيل البياناتsalim1.rar

اخي محمد البرنامج الذي رفعته هو لفصل واحد و لبس هناك وقت لتعبئة نموذج لكل الفصول الرجاء عمل برنامج متكامل (كل شيت يحتوي على فصل واحد في نفس نطاق الخلايا مثلا من C6 لغاية G15 ) حاول عدم استعمال الخلايا المدمجة لتكن اسماء الاساتذة بدون القاب (محمد مثلاً و ليس أ.مجمد) و اخيراً ضع قائمة بأسماء الاساتذة في اي مكان من الشيت Teachers( كي يسهل العمل) اذا صادف وجود استاذين ينفس الاسم يجب التمييز بينهما باسم العائلة

نظراً الى ان الاخ زيزو وضع لك نفس الكود تقريباً احببت ان اغير الى هذا الكود Option Explicit Sub Give_Data1() Dim Rfsol, Rteacher, Cel As Range Dim My_name As String Dim adr, adr1 As String Set Rfsol = Sheets("fsol").Range("c6:g15") Set Rteacher = Sheets("teacher").Range("c6:g15") Rteacher.ClearContents My_name = Sheets("teacher").Range("c2") For Each Cel In Rfsol If Cel = My_name Then adr = Cel.Address: adr1 = Cel.Offset(-1, 0).Address Sheets("teacher").Range(adr) = Cel Sheets("teacher").Range(adr1) = Cel.Offset(-1, 0) End If Next End Sub الملف مرفق ترحيل لجدول salimالاستاذ.rar

جرب هذا الماكرو Option Explicit Sub Give_Data() Dim r, c As Integer Dim Rfsol, Rteacher, Cel As Range Dim My_name As String Set Rfsol = Sheets("fsol").Range("c6:g15") Set Rteacher = Sheets("teacher").Range("c6:g15") Rteacher.ClearContents My_name = Sheets("teacher").Range("c2") For Each Cel In Rfsol If Cel = My_name Then r = Cel.Row: c = Cel.Column Sheets("teacher").Cells(r, c).Offset(-1, 0) = Cel.Offset(-1, 0) Sheets("teacher").Cells(r, c) = Cel End If Next End Sub

أختي القاضلة جربي بعد اذنك هذا الملف (صفحة Salim) test 000 Salim.rar