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

السلام عليكم ورحمة الله الملف بعد التعديل اى خلل قم برفع الملف الى مرة اخرى المعادلة تعديل).xlsm

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

السلام عليكم ورحمة الله مرفق الملف بعد نسخ كود الدوال المعرفة و تم التطبيق على مادة واحدة و قياسا عليها يمكنك تكملة باقى المواد و تطبيق الدالة الثانية لا يختلف كثيرا عن الاولى و لكن فى العمود المخصص لها تم حفظ الملف بامتداد XLSM حتى يمكننا حفظ الملف المعادلة باللون.xlsm

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

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

السلام عليكم ورحمة الله دالة Vlookup تهتم بالاعمدة فقط و لا تهتم بالصفوف ما عليك سوى استبدال رقم العمود بالحسبة المذكورة في مشاركتى السابقة و ذلك في الخلية B12 لتصبح المعادلة هكذا =IFERROR(VLOOKUP($F$1;sheet1!$A$9:$DL$108;(ROW()-12)*10+COLUMN(G7);FALSE);"") ثم سحب المعادلة لليسار وللاسفل دون ان ترفعى يدك عن الماوس كررى ماسبق مع الحسبة الثانية في الست اشهر التالية بدأا من الخلية B19 لتصبح المعادلة هكذا =IFERROR(VLOOKUP($F$1;sheet1!$A$9:$DL$108;(ROW()-13)*10+COLUMN(G7);FALSE);"") و الله الموفق و المستعان

السلام عليكم ورحمة الله فى الجزء الخاص بالستة شهور الاولى استخدمى هذه الحسبة بدلا من رقم العمود (ROW()-12)*10+COLUMN(G7) اما الستة شهور الاخيرة فاستخدمى هذه الحسبة وذلك بسبب الصف الفاصل بينهما (ROW()-13)*10+COLUMN(G7) الرجاء عدم التخلى عن اى اقواس

السلام عليكم ورخمة الله تم التعديل Sub ImpClass() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, LS As Long Dim i As Long, p As Long Dim Cls As String, Spld As String, Knd As String Set ws = Sheets("arshef") Set Sh = Sheets("ك.غ") LR = ws.Range("B" & Rows.Count).End(3).Row j = 2 Do While j <= 310 Sh.Range("C" & j + 3).Resize(25).ClearContents Cls = Sh.Range("G" & j).Text Spld = Sh.Range("K" & j).Text Knd = Sh.Range("AF1").Text For i = 5 To LR If ws.Range("Q" & i).Text = Cls Then If ws.Range("P" & i).Text = Spld Then If ws.Range("L" & i).Text = Knd Then p = p + 1 Sh.Range("C" & p + j + 2) = ws.Range("B" & i) End If End If End If Next p = 0 j = j + 28 Loop End Sub

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

السلام عليكم ورحمة الله استخدم الكود التالى Sub ImpClass() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, LS As Long Dim i As Long, p As Long Dim Cls As String Set ws = Sheets("arshef") Set Sh = Sheets("ك.غ") LR = ws.Range("B" & Rows.Count).End(3).Row j = 2 Do While j <= 310 Cls = Sh.Range("G" & j).Text For i = 5 To LR If ws.Range("Q" & i).Text = Cls Then p = p + 1 Sh.Range("C" & p + j + 2) = ws.Range("B" & i) End If Next p = 0 j = j + 28 Loop End Sub

السلام عليكم ورحمة الله ضف هذه العبارة الى اخر سطر فى الكود المسمى TraData ws.Range("A1:K50").ClearContents

السلام عليكم ورحمة الله فى البداية اعتذر لان الكود السابق به خلل و قد تظهر مشاكله لاحقا لذا ارجو ان تستبدل الكود السابق بما يلى اولا يجب ربط الزر (زر الترحيل) بالكود التالى Sub AddSheet() Dim ws As Worksheet, Obj As Object Dim Itm As Variant, C As Range Dim x As Integer Set ws = Sheets("يناير ") Set Obj = CreateObject("Scripting.Dictionary") Set C = ws.Range("J3") x = VBA.Day(C.Value) If Not Obj.exists(x) Then Obj.Add x, x End If For Each Itm In Obj.keys If Not ShExists(Obj(Itm)) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = Itm End If Next Call TraData End Sub ثانيا نسخ ولصق الكود و الدالة المعرفة التاليين فى موديول مستقل داخل الملف ايضا ولا تربط ايا منهما بأى زر الكود هو Sub TraData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, ShName Set ws = Sheets("يناير ") ShName = Day(ws.Range("J3")) ws.Range("A1:K50").Copy For Each Sh In Worksheets If Sh.Name = ShName Then Sh.Range("A1").Select Selection.PasteSpecial xlPasteAll Selection.PasteSpecial xlPasteColumnWidths End If Next Application.CutCopyMode = False End Sub و الدالة هى Function ShExists(ShNam As String, Optional WB As Workbook) As Boolean Dim Sh As Worksheet If WB Is Nothing Then Set WB = ThisWorkbook On Error Resume Next Set Sh = WB.Sheets(ShNam) On Error GoTo 0 ShExists = Not Sh Is Nothing End Function و غدا ان شاء الله كود مسح البيانات السابقة ان كان فى العمر بقية

السلام عليكم ورحمة الله استخدم هذا الكود Sub TraData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, ShName Set ws = Sheets("يناير ") ShName = Day(ws.Range("J3")) ws.Range("A1:K50").Copy On Error Resume Next If Len(Trim(ShName)) > 0 Then If Len(Sheets(ShName).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = ShName End If End If Sheets(ShName).Range("A1").Select Selection.PasteSpecial xlPasteAll Selection.PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله جرب هذا الكود Sub Collected() Dim ws As Worksheet, Arr As Variant, Tmp As Variant Dim LR As Long, LS As Long, Sh As Worksheet Set ws = Sheets("Feuil1") Set Sh = Sheets("تجميع") t = Timer Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range Set Rng1 = ws.Range("A2:F" & ws.Range("B" & Rows.Count).End(3).Row) Set Rng2 = ws.Range("H2:M" & ws.Range("I" & Rows.Count).End(3).Row) Set Rng3 = ws.Range("O2:T" & ws.Range("P" & Rows.Count).End(3).Row) Arr = Array(Rng1, Rng2, Rng3) Application.ScreenUpdating = False Sh.Range("A2:F1000").ClearContents For i = LBound(Arr) To UBound(Arr) Arr(i).Copy LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Sh.Range("A" & LR).PasteSpecial xlPasteAll Next Application.CutCopyMode = False LS = Sh.Range("B" & Rows.Count).End(3).Row For j = 2 To LS Sh.Range("A" & j) = j - 1 Next Application.ScreenUpdating = True 'MsgBox Round(Timer - t, 2) End Sub

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

السلام عليكم ورحمة الله تم تعديل الكود بحيث تقوم انت اولا بتحديد النطاق المراد عد الدوائر فية ثم الضغط على الزر المربوط به هذا الكود فتظهر لك رسالة بعدد الدوائر فى هذا النطاق Sub Shap_Count3() Dim sh As Shape For Each sh In ActiveSheet.Shapes If Not Intersect(Selection, sh.TopLeftCell) Is Nothing Then p = p + 1 End If Next MsgBox "عدد الدوائر فى الورقة هو : " & p & " دائرة" End Sub

السلام عليكم ورحمة الله استخدم الكود التالى Sub Shap_Count() Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.AutoShapeType = msoShapeOval Then p = p + 1 End If Next MsgBox "عدد الدوائر فى الورقة هو : " & p & " دائرة" End Sub

السلام عليكم ورحمة الله ضع المعادلة التالية فى العمود F =IFERROR(IF(SEARCH("مرتجع";$C2)=0;$D2*$E2;"");"") اما هذه المعادلة فضعها فى العمود G =IFERROR(IF(SEARCH("مرتجع";$C2)>0;$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

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

السلام عليكم ورحمة الله الكود الاول لمسح الدوائر Sub DelShap() Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.AutoShapeType = msoShapeOval Then sh.Delete End If Next End Sub الكود الثانى لرسم الدوائر للحصص الزائدة Sub AddCircles1() Dim Shp As Shape Dim i As Long, j As Long, p As Long Dim C As Range, x As Integer x = Range("V1").Value i = 10 Do While i >= 7 j = 4 For Each C In Range(Cells(j, i), Cells(12, i)) If C.Value <> "" Then Set Shp = Sheet1.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 الكود الاخير لرسم الدوائر فى الجدول الثانى Sub AddCircles2() Dim Shp As Shape Dim i As Long, j As Long, p As Long Dim C As Range, x As Integer DelShap x = Range("W1").Value i = 13 Do While i <= 19 j = 4 For Each C In Range(Cells(j, i), Cells(12, i)) If C.Value <> "" Then Set Shp = Sheet1.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

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

السلام عليكم ورحمة الله استخدم هذا الكود اسرع و افضل Sub الصف_الخامس() Dim LR As Long, erow As Integer, sh28 As Worksheet, sh22 As Worksheet, i As Long Dim Arr As Variant, Tmp As Variant, p As Long t = Timer Application.ScreenUpdating = False Set sh28 = Worksheets(" ملف وتحريري نصف العام صف خامس") Set sh22 = Worksheets("شيت صف خامس") sh22.Range("B14:CZ1000").ClearContents LR = sh28.Cells(Rows.Count, 2).End(xlUp).Row Arr = sh28.Range("B14:EE" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 1) <> Empty Then p = p + 1 For j = 1 To 32 Tmp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 26, 36, _ 46, 48, 58, 83, 87, 91, 95, 99, 103, 17, 27, 37, 47, 59, 104)) = Arr(i, _ Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 116, 117, 118, 119, _ 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133)) 'Tmp(p, 1) = p Next End If Next If p > 0 Then sh22.Range("B14").Resize(p, UBound(Tmp, 2)).Value = Tmp Application.ScreenUpdating = True 'MsgBox Round(Timer - t, 2) End Sub

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

السلام عليكم ورحمة الله الكود التالى يقوم بانشاء ورقة جديدة فى خالة عم وجودها Sub CrNewSheets() Dim dic As Object, Tmp As Variant, Itm Dim i As Long, Bok As Worksheet Set Bok = Sheets("BASS") Set dic = CreateObject("scripting.dictionary") Tmp = Bok.Range("E5:E" & Bok.Range("C" & Rows.Count).End(3).Row).Value For i = 1 To UBound(Tmp) dic(Tmp(i, 1) & "") = "" Next On Error Resume Next For Each Itm In dic.keys If Len(Trim(Itm)) > 0 Then If Len(Worksheets(Itm).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Itm End If End If Next End Sub ضعى هذه العبارة فى اول سطر فى الكود المدرج بمشاركتى الاولى Call CrNewSheets و الزر يخصص للكود الاول فقط