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

السلام عليكم ورحمة الله اكتب المعادلة التالية فى التنسيق الشرطى وحدد اللون الذى تريده =COUNTIFS($A$2:$A$1000;$A2;$B$2:$B$1000;$B2)>1

السلام عليكم ورحمة الله الاخ الكريم الاستاذ / خالد كل عام وانتم بخير موضوعاتك دائما شديدة الروعة و الاهمية جعلها الله فى ميزان حسناتك

السلام عليكم ورحمة الله اخى الكريم الاستاذ / محمد جرب هذا الكود بدون اى تعديل ربما يفيدك Sub aya2() Dim ws As Worksheet, wh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set ws = Worksheets("الراسبين") Set wh = Worksheets("الدور الثانى") wh.Range("B8:Z" & wh.Range("D" & Rows.Count).End(xlUp).Row + 7).ClearContents Arr = ws.Range("B8:AA" & ws.Range("D" & Rows.Count).End(xlUp).Row + 7).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 26) = "ناجح" Then p = p + 1 For j = 1 To 25 Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then wh.Range("B8").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله تفضل اخى الكريم الصف الرابع.rar

السلام عليكم ورحمة الله تفضل اخى الكريم الصف الأول الإبتدائي.rar

السلام عليكم ورحمة الله معذرة اخى الكريم محمد يوجد خطأ فى الكود المرفق بمشاركتى السابقة وها هو الكود الصحيح Sub TransData() Dim Fsl As Worksheet, Tec As Worksheet Dim cel As Range Dim x As Integer, y As Integer, i As Integer Set Tec = Sheets("teachers") Tec.Range("C6:G15").ClearContents For i = 1 To Sheets.Count If Sheets(i).Name <> "teachers" Then Set Fsl = Sheets(i) For Each cel In Fsl.Range("C6:G15") x = cel.Row y = cel.Column If cel.Value = Tec.Range("D2") Then Tec.Cells(x, y) = Fsl.Range("D2") Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value End If Next End If Next End Sub

اخى الكريم السلام عليكم ورحمة الله بعد اذن الاستاذ سليم جرب هذا الكود Sub TransData() Dim Fsl As Worksheet, Tec As Worksheet Dim cel As Range Dim x As Integer, y As Integer, i As Integer For i = 1 To Sheets.Count If Sheets(i).Name <> "teachers" Then Set Fsl = Sheets(i) Set Tec = Sheets("teachers") For Each cel In Fsl.Range("C6:G15") x = cel.Row y = cel.Column If cel.Value = Tec.Range("D2") Then Tec.Cells(x, y) = Fsl.Range("D2") Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value End If Next End If Next End Sub

السلام عليكم ورحمة الله كل عام وانتم بخير ربما يكون هذا هو ماتريده ولكن يوجد اختلاف بين الشهادة الاولى وباقى الشهادات فى الشكل الصفين الثاني والثالث الإبتدائي.rar

السلام عليكم ورحمة الله انسخ هذا الكود وضعه فى موديول وخصص له زر ملحوظة هامة : ان لم تتطابق معك الاسماء فى الجدولين لن يعمل معك الكود بكفاءة Sub TransData() Dim Fsl As Worksheet, Tec As Worksheet Dim cel As Range Dim x As Integer, y As Integer Set Fsl = Sheets("fsol") Set Tec = Sheets("teacher") For Each cel In Fsl.Range("C6:G15") x = cel.Row y = cel.Column If cel.Value = Tec.Range("C2") Then Tec.Cells(x, y) = Fsl.Range("C2") Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value End If Next End Sub

السلام عليكم ورحمة الله كل عام وانتم بخير الاستاذ سليم موضوعاتك مميزة دائما كالعادة لا تحرمنا من ابداعاتك

السلام عليكم ورحمة الله اخى الكريم الاستاذ سليم / كل عام وانتم بخير بمناسبة شهر رمضان المعظم اخى الكريم لا داعى ابدا للاعتذار فأنت احد اعلام هذا المنتدى ودخولك على اى موضوع هو شرف لكل المشاركين فيه

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Rem كود يقوم بترتيب وفرز البيانات بمجرد الكتابة LR = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Rem المدى المراد فرزه Range("a2:a" & LR).Select Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range("a3").Select End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة . بافتراض ان المبلغ فى الخلية " A1 " =INT(A1/5)*5

السلام عليكم ورحمة الله شكرا لك استاذى العزيز / خالد نصائحك دائما فى العقل والقلب بارك الله فيك و فى جميع اساتذتنا الاجلاء

السلام عليكم ورحمة الله نعم اخى العزيز يمكن ذلك استبدل الكود السابق بهذا الكود Sub ResultLastY() Dim ws As Worksheet, Nag As Worksheet, Ras As Worksheet Dim Arr As Variant, Temp As Variant Dim i, j, p, q As Long Dim Sresult As String Set ws = Sheets("إدارة") Set Nag = Sheets("ناجحين") Set Ras = Sheets("راسبين") Sresult = ws.Range("W2").Value Arr = ws.Range("B6:U" & ws.Range("B" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 20) = Sresult Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If Sresult = "ناجح" Then Nag.Range("A6:U" & Nag.Range("B" & Rows.Count).End(xlUp).Row).Clear Nag.Range("B6").Resize(p, UBound(Temp, 2)).Value = Temp Nag.Range("A6") = 1 Nag.Range("A6").Resize(p).DataSeries step:=1 Nag.Range("A6:U" & Nag.Range("B" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin ElseIf Sresult = "دور ثان" Then Ras.Range("A6:U" & Ras.Range("B" & Rows.Count).End(xlUp).Row).Clear Ras.Range("B6").Resize(p, UBound(Temp, 2)).Value = Temp Ras.Range("A6") = 1 Ras.Range("A6").Resize(p).DataSeries step:=1 Ras.Range("A6:U" & Ras.Range("B" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin End If End Sub

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

السلام عليكم ورحمة الله تفضل Book1.rar

السلام عليكم ورحمة الله تم التعديل وتم تجريب الكود بعد عمل صفحة جديدة غير محمية حيث لم اتمكن من التجربة فى المرات السابقة اليك الكود Sub TransKinds() Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Dim Kname As String Set ws = Sheets("حركة اليوميه") Set sh = Sheets("كارت الصنف") Kname = sh.Range("F2").Value Application.ScreenUpdating = False Arr = ws.Range("D5:O" & ws.Range("F" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 3) = Kname Then p = p + 1 For j = 1 To 10 Temp(p, j) = Arr(i, Choose(j, 1, 4, 3, 6, 7, 8, 9, 10, 11, 12)) Next End If Next If p > 0 Then sh.Range("E5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اخى الكريم اليك ماطلبت ارجو من الله عز وجل ان يكون الشرح واضح Sub Circles() 'استدعاء كود المسح اولا Call DeletingShp 'متغيرات Dim ws As Worksheet Dim Arr() As Variant Dim LR As Long, R As Long, i As Long Dim Cel As Range 'اسم صفحه العمل Set ws = Sheets("شيت") ' هذا شرط الا يعمل الكود قبل الصف 14 If LR < 14 Then LR = 14 'متغير لعد الصفوف LR = ws.Range("C" & Rows.Count).End(xlUp).Row 'ارقام الاعمده المطلوب وضع دوائر فيها Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37) 'بدايه الصفوف For R = 14 To LR ' عرض المصفوفة الخاصة بالاعمدة For i = LBound(Arr) To UBound(Arr) ' نطاق تطبيق الامر وهو الخاص برسم الدوائر For Each Cel In ws.Cells(R, Arr(i)) ' الشرط الذى على اساسه سوف يتم رسم الدوائر If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height) ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية xx.Fill.Visible = msoFalse xx.Line.ForeColor.SchemeColor = 10 xx.Line.Weight = 1.2 End If Next Next Next End Sub ' الكود الثانى Sub DeletingShp() '' المتغيرات Dim shp As Shape, x As Long ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها For Each shp In ActiveSheet.Shapes ' امر المسح If shp.Type = 1 Then shp.Delete: x = x + 1 Next shp ' رسالة بعدد الدوائر التى تم مسحها 'MsgBox "تم حذف " & x & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub

السلام عليكم ورحمة الله استخدم الكود التالى لمسح الدوائر و استخدم زر " Button" بدلا من استخدام الشكل التلقائى Sub DeletingShp() Dim shp As Shape, x As Long For Each shp In ActiveSheet.Shapes If shp.Type = 1 Then shp.Delete: x = x + 1 Next shp MsgBox "تم حذف " & x & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub

السلام عليكم ورحمة الله نعم اخى العزيز ضع هذه العبارة فى بداية الكود الاول Call DeletingShp

السلام عليكم ورحمة الله استبدل هذه العبارة If shp.Type = msoAutoShape Or shp.Type = msoShapeOval Then shp.Delete بهذه العبارة If shp.Type = msoShapeOval Then shp.Delete

السلام عليكم ورحمة الله اخى الكريم سليم المعادلة تعطى نتيجة لمنتج غير موجود وهو منتج 6 اعتقد ان المعادلة الصحيحة هى =IF(E3="";"";MAX(IF(E3=B$2:B$14;A$2:A$14;0)))

السلام عليكم ورحمة الله اكتب المعادلة التالية : =MAX(IF(E3=B$2:B$14;$A$2:$A$14;"")) ثم اضغط "Crtl + Shift + Enter" ثم اسحب نزولا حتى آخر خلية

السلام عليكم ورحمة الله كود مسح الدوائر Sub DeletingShp() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.Type = msoAutoShape Or shp.Type = msoShapeOval Then shp.Delete Next End Sub