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

السلام عليكم ورحمة الله
انسخ هذا الكود والصقه فى حد الصفحة
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$D$7" Then Exit Sub Range("B11:C41").ClearContents For R = 3 To Sheet1.Range("B" & Rows.Count).End(xlUp).Row If Sheet1.Cells(R, "B") = Target Then Range("B11:B41") = WorksheetFunction.Transpose(Sheet1.Range("D" & R & ":AD" & R)) Range("C11:C41") = WorksheetFunction.Transpose(Sheet1.Range("D2:AD2")) End If Next For S = 11 To 41 If IsError(Cells(S, "B")) Or IsError(Cells(S, "C")) Then Cells(S, "B").ClearContents Cells(S, "C").ClearContents End If Next End Sub  

=IFERROR(INDEX(Table1[القيمة];MATCH(A2;Table1[[المخالفة ]];0);1);"") السلام عليكم ورحمة الله
اكتب هذه المعادلة و اسحب نزولا
 

السلام عليكم و رحمة الله
استخدم هذا الكود
Sub Summing() Dim C As Range, i As Long Dim a As Integer, b As Integer i = 3 Do While i <= 4 a = Range("E" & i): b = Range("F" & i) For Each C In Range("A3:A9") If C.Value >= a And C.Value <= b Then k = k + C.Offset(0, 1) Range("G" & i) = k End If Next k = 0 i = i + 1 Loop End Sub  

السلام عليكم ورحمة الله
استخدم هذا الكود
Sub Tarhil() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim Setlt As String Set ws = Sheets("كشف السداد") Set Sh = Sheets("حساب العملاء") Setlt = "تم السداد" LR = ws.Range("B" & Rows.Count).End(xlUp).Row Arr = ws.Range("B5:F" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 5) = Setlt Then p = p + 1 For j = 1 To 4 Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5)) Next End If Next If p > 0 Then Sh.Range("B4").Resize(p, UBound(Temp, 2)).Value = Temp End Sub  

السلام عليكم و رحمة الله
ضع الكودين الآتيين فى حدث الفورم
Private Sub CommandButton1_Click() Dim ws As Worksheet, Knd As String Dim x As Integer, Trgt As Range Set ws = Sheets("ورقة1") If Me.ComboBox1.Value = "" Or Me.TextBox1.Value = "" Then MsgBox "يرجى استكمال البيانات" Exit Sub End If Knd = Me.ComboBox1.Value x = WorksheetFunction.Match(Knd, ws.Range("A1:F1"), 0) Set Trgt = ws.Cells(2, x) Trgt.Value = Trgt.Value + Me.TextBox1.Value Me.ComboBox1.Value = "" Me.TextBox1.Value = "" End Sub Private Sub UserForm_Initialize() For Each c In Range("A1:F1") Me.ComboBox1.AddItem c Next End Sub  

السلام عليكم و رحمة الله
اليك شرح الكود المطلوب ارجو ان اكون قد وفقت
Sub LastTest() '-------------------- Dim i As Long, ws As Worksheet, Rng As Range Dim C As Range, p As Integer, x Dim Shp As Shape, Nam As String Set ws = Sheets("Sheet2") Application.ScreenUpdating = False Range("AO5:BB100") = "" ' مسح النطاق الذى سوف يتم ارسال بيانات التلاميذ الضعاف Set Shp = ws.Shapes(Application.Caller) ' تعريف الشكل حسب العنوان المكتوب عليه Nam = Shp.TextEffect.Text ' الاسم المكتوب على الشكل ws.Range("AQ1") = " الطلاب الضعاف اقل من 65 % ل" & Nam ' عبارة تكتب عقب الضغط على اى زر حسب الشهر p = 4 ' لعد التلاميذ الضعاف بدلا من الصفر يعنى i = 5 ' اول صف سوف يتم العمل عليه Do While i <= 70 ' آخر صف سوف يتم العمل عليه حسب المرفق و يم تغييره بسهولة With ws Select Case Nam ' الاعمدة التى سوف يتم العمل عليها حسب اسم الشهر المكتوب على الزر Case "شهر 10" x = Array(1, 2, 3, 4, 5, 6, 7, 11, 15, 19, 23, 27, 31, 35) Case "شهر 11" x = Array(1, 2, 3, 4, 5, 6, 8, 12, 16, 20, 24, 28, 32, 36) Case "شهر 12" x = Array(1, 2, 3, 4, 5, 6, 9, 13, 17, 21, 25, 29, 33, 37) Case Else End Select For j = LBound(x) To UBound(x) ' عدد الاعمدة المطلوبة للعمل عليها و تكون مصفوفة Set Rng = .Cells(i, x(j)) ' التعريف بالنطاق و جعل كل صف على حدة كمصوفة مستقلة بذاتها For Each C In Rng ' كل خلية فى هذا النطاق y = .Cells(4, x(j)) * 0.65 ' شرط النجاح If .Cells(i, x(j)) < y Then ' اذا كان الشرط غير متوافر m = m + 1 ' عد مواد الرسوب اقل من 65% If m > 1 Then GoTo 88: ' تكفى مادة واحدة ليبدأ للعمل عليها p = p + 1 ' العد For a = 0 To 13 ' عدد الخلايا التى سيتم ترحيل البيانات اليها .Cells(p, a + 41) = .Cells(i, x(a)) ' ترحيل البيانات .Cells(p, 41) = p - 4 ' مسلسل للتلاميذ الضعاف Next End If Next Next End With 88: m = 0 i = i + 1 Loop End Sub  

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

السلام عليكم و رحمة الله
استخدم هذه الدالة المعرفة
عليك بتحديد الصف الاول الذى سوف يتم جمعه Rng  و من ثم استخراج النسبة المحددة و السحب لاسفل
Function AllPerc(Rng As Range) As Double Dim x As Integer, y x = WorksheetFunction.Sum(Rng.Value) If x >= 8001 Then: y = x * 0.045 '-------------------- ElseIf x >= 7501 Then: y = x * 0.0425 '-------------------- ElseIf x >= 7001 Then: y = x * 0.0375 '-------------------- ElseIf x >= 6001 Then: y = x * 0.03 '-------------------- ElseIf x >= 5501 Then: y = x * 0.025 '-------------------- ElseIf x >= 5001 Then: y = x * 0.0175 '-------------------- ElseIf x >= 4501 Then: y = x * 0.015 '-------------------- ElseIf x >= 4001 Then: y = x * 0.01 '-------------------- ElseIf x >= 3001 Then: y = x * 0.005 '-------------------- Else y = 0 End If AllPerc = y End Function  

السلام عليكم و رحمة الله
استخدم الكود التالى
Sub CallData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, y As Long Dim C As Range, Temp() Dim Counter As Long Set ws = Sheets("Sheet4") t = Timer Application.ScreenUpdating = False '----------------- On Error Resume Next ws.Range("A2:C1000").ClearContents For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) LR = Sh.Range("A" & Rows.Count).End(3).Row Counter = Counter + LR Next '----------------- ReDim Preserve Temp(Counter, 4) y = 0 For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) For Each C In Sh.Range("A2:A" & LR) If Len(C.Value) > 0 Then Temp(y, 0) = C.Value Temp(y, 1) = C.Offset(0, 1) Temp(y, 2) = C.Offset(0, 2) y = y + 1 End If Next Next '----------------- If y > 0 Then ws.Range("A2").Resize(y, 4).Value = Temp '----------------- Application.ScreenUpdating = True MsgBox Round(Timer - t, 2) End Sub  

السلام عليكم و رحمة الله
استخدم هذه المعادلة
=INDEX($E$2:$E$11;MATCH(VALUE(LEFT(E2;SEARCH("-";E2)-1));$A$2:$A$11;0))  

السلام عليكم و رحمة الله
الكود التالى ضعه فى كلاس موديول و سمه (اى الكلاس موديول)  ClsButn
Public WithEvents Btn As MSForms.CommandButton Sub Btn_Click() Dim ws As Worksheet For Each ws In Worksheets If Btn.Caption = ws.Name Then ws.Visible = True Else On Error Resume Next ws.Visible = False End If Next End Sub اما الكود التالى فضعه فى حدث الفورم
Dim MyBtn(1 To 9) As New ClsButn Private Sub UserForm_Initialize() For i = 1 To 9 Set MyBtn(i).Btn = Me.Controls("CommandButton" & i) Next End Sub اضغط على الزر مرتين لكى يعمل معك الكود بصورة صحيحة
هذا و الله اعلى و اعلم

السلام عليكم و رحمة الله
استخدم المعادلة التالية
=IF(COUNTIFS($B$6:B6;B6;$F$6:F6;F6;$K$6:K6;K6)>1;"سبق وتم إدخاله";"")  

السلام عليكم و رحمة الله
استخدم الكود التالى
Sub GetClass() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, Arr As Variant, Temp As Variant, Temp2 As Variant Dim i As Long, j As Integer, Fasl As String Dim Clss As String, p As Integer Set Sh = Sheets("قوائم فصول ") Sh.Range("B12:E46") = "" Sh.Range("I12:L46") = "" Fasl = Sh.Range("L1").Text Clss = Right(Fasl, 1) '----------------------- Select Case Clss Case 1 Set ws = Sheets("البيانات الأساسية الأول") Case 2 Set ws = Sheets("البيانات الأساسية الثاني") Case 3 Set ws = Sheets("البيانات الأساسية الثالث") Case Else End Select LR = ws.Range("D" & Rows.Count).End(3).Row Arr = ws.Range("D7:N" & 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)) '----------------------- For i = 1 To UBound(Arr, 1) If Arr(i, 3) Like Fasl Then p = p + 1 If p <= 35 Then For j = 1 To 4 Temp(p, j) = Arr(i, Choose(j, 1, 1, 10, 11)) Temp(p, 1) = p '----------------------- Next ElseIf p > 35 Then For j = 1 To 4 Temp2(p - 35, j) = Arr(i, Choose(j, 1, 1, 10, 11)) Temp(p - 35, 1) = p Next End If End If Next '----------------------- If p > 0 Then Sh.Range("B12").Resize(p, UBound(Temp, 2)).Value = Temp If p > 35 Then Sh.Range("I12").Resize(p, UBound(Temp2, 2)).Value = Temp2 End Sub  

السلام عليكم و رحمة الله
اجعل الدالة هكذا
=COUNTIF(A1:A230;"<>"&"0")  

السلام عليكم و رحمة الله
شاهد هذا المرفق ربما يكون هو طلبك
يمكنك التعديل عليه بما يتوافق مع رغباتك
 
 
ViewPicts.rar

السلام عليكم و رحمة الله
اجعل الكود هكذا
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Columns("A"), Target.Cells) Is Nothing Then UserForm1.Show 0 Else Exit Sub End If End Sub  

السلام عليكم و رحمة الله
هو نفس الكود بدون اى تغيير
و لكن يتم و ضعه فى حدث الملف ThisWorkBook  هكذا
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False ' اجعل جميع خلايا ورقة العمل الحالية بدون لون Cells.Interior.ColorIndex = 0 With Target ' لون كامل سطر الخلية الفعالة .EntireRow.Interior.ColorIndex = 8 ' لون كامل عمود الخلية الفعالة .EntireColumn.Interior.ColorIndex = 8 End With Application.ScreenUpdating = True End Sub  

السلام عليكم و رحمة الله
استخدم المعادلة التالية بدلا من المعادلة الحالية
فى عمود الرقم
=IFERROR(INDEX('أسماء الطلاب'!$A$2:$E$890;SMALL(IF('أسماء الطلاب'!$E$2:$E$890=$E$9;ROW('أسماء الطلاب'!$E$2:$E$890));ROW(A1))-1;1);"") و فى عمود الاسم غير الرقم 1 الى الرقم 2
المعادلتين معادلات صفيف
اى يجب الضغط على CTRL + SHIFY + ENTER لكى تعمل معك المعادلة

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

السلام عليكم و رحمة الله
استخدم المعادلة التالية
=IF(COUNTIFS($B$2:$B$220;B2;$C$2:$C$220;C2)>1;"مكرر";"")  

السلام عليكم و رحمة الله
ضع هذا فى حدث الفورم  و عدل فقط اسم الشيت و عنوان الخلية
Private Sub UserForm_Initialize() Me.TextBox1.Value = Format(Sheet1.Range("A1"), ".00%") End Sub  

السلام عليكم و رحمة الله
و كل عام و انتم بخير
المعادلة التالية توضع فى الخلية G6 ثم نضغط CTRL+SHIF+ENTER لانها معادلة صفيف و بعدها نسحب طولا و عرضا ليوم الاثنين فقط
=IFERROR(INDEX('جدول توزيع الحصص'!$B$7:$H$12;MATCH(($C9&$G$6&G$7);'جدول توزيع الحصص'!$B$7:$B$12&'جدول توزيع الحصص'!$C$7:$C$12&'جدول توزيع الحصص'!$G$7:$G$12;0);3);"") اما بقى الايام نقوم بتغيير الخلية G6  فى المعادلة ذاتها  الى P6 ليوم الثلاثاء و  Y6 ليوم الاربعاء و  AH6 ليو م الخميس و  AQ6 ليوم السبت
هذا و الله ولى التوفيق

السلام عليكم و رحمة الله
تم تبديل الاعمدة لتتوافق مع طلبك
=IF(COUNTIFS($B$3:$B$22;F3;$C$3:$C$22;G3)>0;"مطابق";"غير مطابق")  

السلام عليكم و رحمة الله
جرب هذا الكود
Sub AbsData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long, j As Long Dim C As Range, Name As String, dat Set ws = Sheets("Sheet2") Set Sh = Sheets("Sheet3") LR = Sh.Range("C" & Rows.Count).End(3).Row i = 8 Do While i <= LR Name = Sh.Range("C" & i) For Each C In ws.Range("C2:C20") j = 4 Do While j <= 34 If C.Value = Name And C.Offset(0, 1) = "غ" _ And C.Offset(0, 2) = Sh.Cells(7, j) Then Sh.Cells(i, j) = "غ" End If j = j + 1 Loop Next i = i + 1 Loop End Sub  

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