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

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

السلام عليكم ورحمة الله
اجعل الكود هكذا
Sub ADD_DESCRIPTION() Dim ws As Worksheet, LR As Long, C As String Dim x As Byte Set ws = Sheets("DEFINITIONS") LR = ws.Range("D" & Rows.Count).End(xlUp).Row C = Me.TextBox1.Value x = WorksheetFunction.CountIf(ws.Range("D2:D" & LR), C) If x > 0 Then MsgBox "هذا البيان موجود ولا يجب تكرار إضافته" Exit Sub Else: ws.Range("D" & LR + 1) = C MsgBox "تم إضافة البيان الجديد بنجاح" Range([d2], [d2].End(xlDown)).Select Selection.Sort [d2], xlAscending Range("A1").Select TextBox1 = "" TextBox1.SetFocus End If End Sub  

السلام عليكم ورحمة الله
استخدم هذا الكود
Sub AdSh_Data() Dim ws As Worksheet, C As Range Dim x As Byte, WF As Object Dim LR As Long, Sh As Worksheet Set ws = Sheets("ورقة1") Set WF = Application.WorksheetFunction LR = ws.Range("A" & Rows.Count).End(3).Row For Each C In ws.Range("A1:A" & LR) x = WF.CountIf(ws.Range("A1:A" & C.Row), C) On Error Resume Next If x = 1 Then If Len(Sheets(C).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value End If End If Next 88: For Each Sh In ThisWorkbook.Worksheets For Each C In ws.Range("A1:A" & LR) If Sh.Name = C.Value Then p = p + 1 Sh.Range("A" & p).Resize(, 8) = ws.Cells(C.Row, 1).Resize(, 8).Value End If Next p = 0 Next End Sub  

السلام عليكم ورحمة الله
استخدم تلك المعادلة
=IF(LEN(C4)>0;YEAR(TODAY())-MIN(YEAR(C4);D4);YEAR(TODAY())-YEAR(D4))  

السلام عليكم ورحمة الله
استخدم الكود التالى
Sub Cold_Cells() i = 2 Do While i <= 30 For Each c In Range("F2:F8") If Cells(i, 9) = c.Value Then Cells(i, 9).Interior.ColorIndex = 6 End If Next i = i + 1 Loop End Sub  

السلام عليكم ورحمة الله
انا طلبت منك عمل قائمة منسدلة لتسهيل الامر عليك فى التنفيذ
و لكن حقيقة الامر  ما تم تنفيذه عندى باستخدام زر سبينر "Spinner 2"
و لذلك سأرسل اليك الملف بعد التعديل لتطلع عليه بنفسك
نهال.xlsm
 

السلام عليكم ورحمة الله
ضع هذه المعادلة فى شيت ديسمبر الخلية D7 ثم اسحب يسارا و للاسفل
=MAX(اكتوبر!D7;نوفمبر!D7) اما المعادلة التالية فى شيت المتوسط فى الخلية  D7 ثم اسحب يسارا وللاسفل
=AVERAGE(اكتوبر!D7;نوفمبر!D7;ديسمبر!D7)  

السلام عليكم ورحمة الله
لعل هذا الكود ان يفى بالغرض
Sub ReArrang_Data() Dim ws As Worksheet, C As Range Dim i As Long, p As Long Set ws = Sheets("Sheet1") p = 3 i = 6 Do While i <= 16 For Each C In ws.Range(Cells(4, i), Cells(19, i)) If Len(C) > 0 Then p = p + 1 ws.Cells(p, 2) = C.Value ws.Cells(p, 3) = C.Offset(0, 1).Value End If Next i = i + 2 Loop End Sub  

السلام عليكم ورحمة الله
تم تحويل الارقام الى نسب مئوية حسب ما فهمت من طلبك
ارجو عدم الاقتراب من الاكواد المدرجة بالملف حتى لا يفسد كل ماعملناه
لانى وجدت احد الاكواد وقد تم حذفها من محرر الاكواد بالملف
هذا والله ولى التوفيق
المعادلة تعديل2 (1).xlsm

السلام عليكم ورحمة الله
استخدم الكود الاتى
Sub SetlColr() Dim ws As Worksheet Dim LR As Long, C As Range Set ws = Sheets("Sheet1") LR = ws.Range("A" & Rows.Count).End(3).Row For Each C In ws.Range("B3:B" & LR) If C.Value > 0 Then x = C.Interior.ColorIndex If x = 6 Then C.Offset(0, 1) = C.Value C.ClearContents Else Exit Sub End If End If Next End Sub  

السلام عليكم ورحمة الله
الكود الاتى يحسب الترتيب حتى العشرة الاوائل
Sub AllRanks() Dim ws As Worksheet, j As Long Dim Arr As Variant, k As Double Dim LR As Long, i As Long Dim m As Integer, n As Integer, x As Integer Set ws = Sheets("مسودة الدرجات") LR = ws.Range("R" & Rows.Count).End(3).Row Dim TP() ReDim Arr(1 To LR, 1 To 1) j = 9 Do While j <= LR y = WorksheetFunction.CountIf(ws.Range(ws.Cells(9, "R"), ws.Cells(j, "R")), ws.Cells(j, "R")) If y = 1 Then i = i + 1 Arr(i, 1) = ws.Cells(j, "R") End If j = j + 1 Loop If i <= 10 Then x = WorksheetFunction.Large(Arr, i) End If ReDim TP(1 To i, 1 To 1) For r = 1 To i If Arr(r, 1) >= x Then p = p + 1 TP(p, 1) = Arr(r, 1) End If Next m = 9 Do While m <= LR For n = 1 To i k = WorksheetFunction.Large(TP, n) If ws.Cells(m, "R") = k Then yy = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") If ws.Range("R" & m) <> Empty Then If WorksheetFunction.CountIf(ws.Range("R9:R" & m), ws.Range("R" & m)) > 1 Then yy = yy & " " & "مكرر" ws.Cells(m, "U") = yy Else yy = yy ws.Cells(m, "U") = yy End If End If End If Next m = m + 1 Loop End Sub  

السلام عليكم ورحمة الله
استخدم هذا الكود
Sub Ranking() p = 3 For i = 4 To Range("C" & Rows.Count).End(3).Row On Error Resume Next If Cells(i, "H") > 0 Then p = p + 1 For j = 1 To 2 Cells(p, Choose(j, 14, 15)) = Cells(i, Choose(j, 3, 8)) Next End If Next Range("N4:O" & Range("N" & Rows.Count).End(3).Row).Sort key1:=Range("O4"), _ order1:=xlDescending, key2:=Range("N4"), order2:=xlAscending End Sub  

السلام عليكم ىورحمة الله
اجعل المعادلة الاولى هكذا
=IF(LEFT($C2;5)<>"مرتجع";$D2*$E2;"") و الثانية هكذا
=IF(LEFT($C2;5)="مرتجع";$D2*$E2;"")  

السلام عليكم ورحمة الله
اليك الكود الثانى
Sub AddCircles2() Dim Shp As Shape, ws As Worksheet Dim i As Long, j As Long, p As Long Dim C As Range, x As Integer, y As Integer 'DelShap Set ws = Sheets("ورقة1") x = ws.Range("W1").Value i = 13 Do While i <= 20 j = 5 For Each C In ws.Range(Cells(j, i), Cells(13, i)) On Error Resume Next y = InStr(C.Value, "/") If C.Value <> "" And y > 0 Then Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, _ C.Left, C.Top, C.Width, C.Height) p = p + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1.5 Shp.Line.ForeColor.SchemeColor = 10 If p >= x Then Exit Sub End If Next j = j + 2 i = i + 1 Loop End Sub  

السلام عليكم ورحمة الله
استخدم تلك المعادلة
=SUMIFS($F$14:$F$35;$I$14:$I$35;"مدفوع")  

السلام عليكم ورحمة الله
استخدم الكود التالى بدلا من الكود السابق
Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, LR As Long Set ws = Sheets("vi") Set Sh = Sheets("DATA") LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B" & LR).Resize(, 3) = Arr End Sub  

السلام عليكم و رحمة الله
اليك الملف
 
مواد التخلف.xlsx

السلام عليكم ورحمة الله
اليك تعديل كود ترحيل الناجحين و الراسبين
اذا شعرت ان تنفيذ الكود يستغرق وقتا طويلا
يمكنك طلب عمل كود جديد يعتمد على المصفوفات و لكن لضيق الوقت 
قمت فقط بتعديل الكود المرفق بالملف 
اما باقى المطلوبات فى وقت لاحق ان شاء الله
اليك الكود و يجب ربطه بزر لتنفيذه فى اى وقت
Sub Tarheel() Dim R As Integer, M As Integer, N As Integer Sheets("ناجح").Range("A11:Q1012").Clear Sheets("دور ثانى").Range("A11:R1012").Clear M = 10: N = 10 Application.ScreenUpdating = False Application.DisplayAlerts = False For R = 11 To 1012 If Cells(R, 14) = "ناجح" Then M = M + 1 Range("A" & R).Range("A1:Q1").Copy With Sheets("ناجح") .Range("A" & M).PasteSpecial xlPasteValues .Range("A" & M).PasteSpecial xlPasteFormats .Range("A" & M).Value = M - 10 End With Application.CutCopyMode = False ElseIf Cells(R, 14) = "دور ثانى" Then N = N + 2 Range("A" & R).Range("A1:R1").Copy With Sheets("دور ثانى") .Range("A" & N).PasteSpecial xlPasteValues .Range("A" & N).PasteSpecial xlPasteFormats .Range("A" & N).Value = (N - 10) / 2 End With Application.CutCopyMode = False End If Next MsgBox (" بحمد الله تم ترحيل الناجحين والدور الثانى") Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub  

السلام عليكم ورحمة الله
استخدم هذه المعادلة
=IF(LEFT($G2;2)="10";"ذكر";IF(LEFT($G2;2)="11";"أنثى";"رقم غير صحيح"))  

السلام عليكم ورحمة الله
ضع هذه المعادلة فى الخلية "B" ثم اضغط  Ctrl+Shift+Enter
ثم اسحب عرضا وطولا
=IFERROR(INDEX(ورقة1!$B$4:$E$8;SMALL(IF(ورقة1!$E$4:$E$8>0;ROW(ورقة1!$E$4:$E$8));ROW(A1))-3;COLUMN()-1);"")  

السلام عليكم ورحمة الله
اكتب هذه المعادلة فى الخلية "C6"
=IFERROR(INDEX(msheet!$D$5:$E$82;SMALL(IF(msheet!$D$5:$D$82=$E$3;ROW(msheet!$D$5:$D$82));ROW(A1))-4;2);"") ثم اصغط "CTRL+SHIFT+ENTER"
ثم اسحب نزولا حتى الخلية "C35"
ثم اكتب المعادلة التالية فى الخلية "E6"
=IFERROR(INDEX(msheet!$D$5:$E$82;SMALL(IF(msheet!$D$5:$D$82=$E$3;ROW(msheet!$D$5:$D$82));ROW(A31))-4;2);"") و كر ر ما سبق

السلام عليكم ورحمة الله
اليك الملف
ابتدائي2020.xlsm

السلام عليكم ورحمة الله
استخدم هذا الكود
Sub Work_Day() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, LR As Long, i As Long Dim x As Integer, Dy As String Dim WF As Object Set ws = Sheets("ورقة2") Set Sh = Sheets("ورقة1") Set WF = WorksheetFunction LR = ws.Range("A" & Rows.Count).End(3).Row i = 2 Do While i <= LR For Each C In Sh.Range("A2:A" & ws.Range("A" & Rows.Count).End(3).Row) If ws.Cells(i, 1) = C.Value Then Dy = C.Offset(0, 1) x = WF.Match(Dy, ws.Range("B1:G1"), 0) ws.Cells(i, 1).Offset(0, x) = Dy End If Next i = i + 1 Loop End Sub  

السلام عليكم ورحمة الله
استخدم الكود التالى 
الرقم السرى 123 يمكنك تغييره كما شئت
Sub Delpics() Dim ws As Worksheet, Pic As Object Dim InBox As String InBox = InputBox(" يرجى ادخال كلمة السر", "ازالة الصور ") For Each ws In Worksheets For Each Pic In ws.Pictures If InBox = "123" Then Pic.Delete Else MsgBox "ارجو وضع الرقم السرى الصحيح ...حاول مرة ثانية" Exit Sub End If Next Next End Sub  

السلام عليكم ورحمة الله
استخدم هذا الكود
Sub addpics() Dim ws As Worksheet For Each ws In Worksheets ws.Pictures.Insert ("D:\عنوان.jpg") Next End Sub