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

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

السلام عليكم ورحمة الله استخدم الكود التالى Sub GetData() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, x As Long, Data Set ws = Sheets("اجمالي") x = 14 For Each C In ws.Range("D3:D" & ws.Range("D" & _ Rows.Count).End(3).Row) For Each Sh In Worksheets If Sh.Name <> ws.Name And Sh.Name = C.Value Then x = WorksheetFunction.CountA(Sh.Range("B14:B" & _ Sh.Range("B" & Rows.Count).End(3).Row)) + 12 C.Offset(0, 1) = Sh.Range("J7") C.Offset(0, 2) = Sh.Range("C" & x) C.Offset(0, 3) = Sh.Range("C" & x + 1) C.Offset(0, 4) = Sh.Range("J" & x) C.Offset(0, 5) = Sh.Range("J" & x + 1) End If Next Next End Sub

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

السلام عليكم ورحمة الله استخدم هذا الكود 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

السلام عليكم ورحمة الله نعم يمكن ذلك من التبويب المطور "Developer"، انقر فوق وحدات الماكرو. في مربع الحوار "ماكرو Macros" ، انقر فوق "خيارات Options ". سيظهر مربع الحوار "خيارات الماكرو". في مربع مفتاح الاختصار ، اكتب أي حرف كبير أو حرف صغير تريد استخدامه للاختصار ، ثم انقر فوق موافق لحفظ التغييرات

السلام عليكم ورحمة الله اجعل الكود هكذا 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

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

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

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

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

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

السلام عليكم ورحمة الله اليك الملف شيت.xlsm

السلام عليكم و رحمة الله اليك هذه الدالة المعرفة ضع المعادلة فى الخلية K5 ثم اسحب نزولا اما الالوان فيمكنك استخدام التنسيق الشرطى Function Expectations(Rng As Range) As Variant Dim i As Double, j As Double Dim Apprn As Variant i = CDbl(Rng.Value) ' Rng هى الخلية التى تحتوى على درجة المقياس If i >= 85 And i <= 100 Then Apprn = "يفوق التوقعات" '-------------- ElseIf i >= 65 And i < 85 Then Apprn = "يلبى التوقعات" '-------------- ElseIf i >= 50 And i < 65 Then Apprn = "يلبى التوقعات أحيانا" '-------------- ElseIf i < 50 Then Apprn = "أقل من المتوقع" '-------------- End If Expectations = Apprn End Function

السلام عليكم ورحمة الله استخدم الكود التالى 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

السلام عليكم ورحمة الله فى البداية يجب انشاء قائمة منسدلة فى الخلية N7 تبدأ برقم 1 حتى يعمل معك الكود بشكل صحيح ثم استخدم الكود التالى Sub StudId() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant Dim i As Integer, j As Integer, p As Integer Dim x As Integer, y As Integer, m As Integer Dim Fsl As String, n As Integer Set ws = Sheets("جدول الامتحان مع رقم الجلوس 1") Set Sh = Sheets("شيت صف رابع") '--------------------- Arr = Array("B7", "B8", "B9", "E8", "B20", "B21", "B22", "E21", _ "B33", "B34", "B35", "E34", "B46", "B47", "B48", "E47") For m = 0 To UBound(Arr) ws.Range(Arr(m)).ClearContents Next '---------------------- LR = Sh.Range("B" & Rows.Count).End(3).Row Fsl = ws.Range("N17").Text n = ws.Range("N2").Value x = (n - 1) * 4 + 1 y = n * 4 For i = 14 To LR If Sh.Cells(i, 4).Text = Fsl Then p = p + 1 If p >= x And p <= y Then j = (p - x) * 13 + 7 ws.Cells(j, 2) = Sh.Cells(i, 3) ws.Cells(j + 1, 2) = Sh.Cells(i, 2) ws.Cells(j + 2, 2) = Sh.Cells(i, 5) ws.Cells(j + 1, 5) = Sh.Cells(i, 4) End If End If Next End Sub

السلام عليكم ورحمة الله تم تصحيح الكود ليعمل بشكل صحيح و لكن يتوجب عليك تسطير الكثير من الجداول التى سوف يتم تفريغ البيانات بها و ليس 4 فقط كما هو موضح فى الملف المرفق مع مشاركتك الاولى اليك الكود Sub StudId() Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Tmp As Variant Set ws = Sheets("جدول الامتحان مع رقم الجلوس 1") Set sh = Sheets("شيت صف رابع") lr = sh.Range("B" & Rows.Count).End(3).Row fsl = ws.Range("N17").Text For i = 14 To sh.Range("D" & Rows.Count).End(3).Row If sh.Cells(i, 4) = fsl Then p = p + 1 x = (p - 1) * 13 + 7 ws.Cells(x, 2) = sh.Cells(i, 3) ws.Cells(x + 1, 2) = sh.Cells(i, 2) ws.Cells(x + 2, 2) = sh.Cells(i, 5) ws.Cells(x + 1, 5) = sh.Cells(i, 4) End If Next End Sub

السلام عليكم ورحمة الله قم بالغاء هذه العبارة من الكود Exit 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 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

السلام عليكم ورحمة الله استخدم الكود الاتى 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

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

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

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

السلام عليكم ورحمة الله الملف بعد التعديل و ارجو ان اكون قد فهمت طلبك صح المعادلة تعديل2.xlsm