عبد الفتاح كيرة

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

لا أدرى المطلوب بالضبط جرب المرفق ابواحمدkemas.rar

لا بأس لعلك تريده هكذا المرفقات ربط مربع تحرير بقائمة kemas2.rar

أشكرك أستاذ طارق على المعادلة الرائعة واسمح لى بالمشاركة بمعادلة أخرى مع 2007 ستكون قصيرة جدا لكن مع 2003 ستكون =IF(ISERROR(OFFSET(INDEX('2'!$D$3:$L$12;ROW(B4)-ROW($A$3);MATCH('الملخص التفصيلي '!$D$3;'2'!$D3:$L3;0));-(ROW(B4)-ROW($A$3));0));"";OFFSET(INDEX('2'!$D$3:$L$12;ROW(B4)-ROW($A$3);MATCH('الملخص التفصيلي '!$D$3;'2'!$D3:$L3;0)) وذلك لتلافى ظهور الخطأ مع 2007 تكون =IFERROR(OFFSET(INDEX('2'!$D$3:$L$12;ROW(B4)-ROW($A$3);MATCH('الملخص التفصيلي '!$D$3;'2'!$D3:$L3;0));-(ROW(B4)-ROW($A$3));0);"") الملف المرفق 3صفر-kemas.rar

أشكرك جدا أستاذ أبو عاصم بارك الله فيك وشكرا لك

تفضل وهذا من عجائب الأكواد لأن الكمبوبوكس فى فورم والقائمة فى فورم آخر بالتوفيق ربط مربع تحرير بقائمة kemas.rar

انسخ الصفحة و الصقها فى ورقة جديدة واختر لصق خاص ثم لصق القيم و التنسيقات

أستاذنا الفاضل تحية طيبة نرجو أن يكون سؤالك أكثر تحديدا حدد جزئية معينة يساعدك فيها الإخوة تطور بها برنامجك مع الشكر

أهلا و سهلا بك أستاذ ياسر أشكر لك ثناءك الطيب و خلقك العالى وتشرفت بمرورك هنا

أخى سعد أشكر لك جميل خلقك و عذب كلامك وفقك الله لكل خير

Alt+f11 لإظهار محرر الفجوال من قائمة insert---- userform ستظهر أدوات التحكم أوتوماتيكيا إذا اختفت لها أيقونة تظهرها من شريط القوائم أو view --- toolbox

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

تفضل أخى قصى كما تحب و تريد مع البيانات المنظمة كل شىء سهل إن شاء الله مفيش حد ناجح إلا الأستاذ خبور بس و أنا و الحسامى دور تانى ينفع كده؟ :biggrin: :biggrin: التصفيه المتقدمةkemas.rar

كليك يمين على الخلية تنسيق خلايا محاذاة احتواء مناسب

تفضل أخى قصى تم التعديل لجلب كل أعمدة الناجحين التصفيه المتقدمةkemas.rar

أخى قصى أنا قمت بالرد على استفسارك يجب أن يكون هناك تسميات لكل الأعمدة ولا تكون هناك صفوف فارغة لذلك أنا أضفت صفا جديدا قبل البيانات وجعلت به تسميات الأعمدة أما الأعمدة التى استدعيناها فهى المسلسل و الاسم و نتيجة الطالب ويمكننا توسيع ذلك حسب الطلب إن شئت

أخى قصى التصفية المتقدمة تحتاج لنطاق بيانات منظم يعنى صف به مسميات الأعمدة ليس به اسم عمود فارغ ويلى ذلك البيانات مباشرة قمت بعمل بعض التعديلات للتمكن من تطبيق التصفية يمكنك إخفاء و ليس حذف الأعمدة التى أضفناها وشكرا التصفيه المتقدمةkemas.rar

أخى المعادلة مرتبطة بمكانها فى الخلية =SUMPRODUCT(--(TruckS!$J:$J=ورقة1!$A4)*(TruckS!$H:$H=ورقة1!$B$3))

تفضل السطر رقم 15 Sub Start_Circles() Dim C As Range Dim MyRng As Range, V As Shape Dim X As Integer, G As Integer, R As Integer, D As Integer '================================================ G = 5 ' ÚãæÏ ãÌãæÚ ÇáÝÕáíä R = 13 ' ÕÝ ÇáÏÑÌÇÊ Set MyRng = Range("g17:ar1000") ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ '================================================ X = ActiveWindow.Zoom Application.ScreenUpdating = False Call Remove_Circles ActiveWindow.Zoom = 100 For Each C In MyRng If C = 0 Then GoTo 1 If Cells(C.Row, G) <> "ãÌãæÚ ÇáÝÕáíä " Then GoTo 1 If Cells(C.Row, G) = 0 Or Cells(C.Row, G) = " " Then GoTo 1 If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "Û" Or C.Value = "ÛÜ") And C.Value <> "" Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 2 D = D + 1 End If 1 Next ActiveWindow.Zoom = X Application.ScreenUpdating = True MsgBox "Êã ÅÖÇÝÉ " & D & " ÏÇÆÑÉ ÈäÌÇÍ", vbMsgBoxRtlReading, "ÇáÍãÏááå" Set MyRng = Nothing End Sub Sub Remove_Circles() Dim shp As Shape, D As Integer For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete: D = D + 1 Next shp 'MsgBox "Êã ÍÐÝ " & D & " ÏÇÆÑÉ ÈäÌÇÍ", vbMsgBoxRtlReading, "ÇáÍãÏááå" End Sub If C = 0 Then GoTo 1 لكن ممكن طالب يكون مجموع درجاته صفرا الدوائر الحمراء-kemas.rar

بارك الله فيك أخى للأستاذ جمال معذرة لتأخرى بالرد جرب هذا الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myc As Range Dim myr As Range On Error Resume Next If Not Intersect(Target, Range("a1:b100")) And Intersect(Target, Range("i1:j100")) Is Nothing Then Set myr = Range("c1:c100") For Each myc In myr If myc.Offset(0, -2) = "" Then myc.Offset(0, 8) = "" myc.Offset(0, 7) = "" myc.Offset(0, 6) = "" myc = "" End If myc.Offset(0, 8) = myc.Offset(0, 7).Value * myc.Offset(0, 6).Value myc = myc.Offset(0, -2).Value * myc.Offset(0, -1).Value Next myc End If Set myr = Nothing End Sub

تفضل Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myc As Range Dim myr As Range On Error Resume Next If Not Intersect(Target, Range("a1:b100")) And Intersect(Target, Range("i1:j100")) Is Nothing Then Set myr = Range("c1:c100") For Each myc In myr myc.Offset(0, 8) = myc.Offset(0, 7).Value * myc.Offset(0, 6).Value myc = myc.Offset(0, -2).Value * myc.Offset(0, -1).Value Next myc End If Set myr = Nothing End Sub

لماذا لا تجعل نطاق القيم المخزونة فى صفحة أخرى و تعطيه اسما راجع الكود فى المرفق delete row in range.zip

لعل هذا ما تريده Sub insertB() Dim myr As Range Dim myc As Range With Sheets(1) Set myr = Range("b3:b100") End With For Each myc In myr If myc.Offset(0, 1) = "" And myc.Offset(0, -1) <> "" Then myc = myc.Offset(0, 1).End(xlUp) End If Next myc End Sub SORT-2kemas.rar

غير الكود إلى هذا Dim myc As Range Dim myr As Range On Error Resume Next If Not Intersect(Target, Range("a1:b100")) Is Nothing Then Set myr = Range("c1:c100") For Each myc In myr myc = myc.Offset(0, -2).Value * myc.Offset(0, -1).Value Next myc End If Set myr = Nothing

أخى الفاضل أعطنا مثالا محلولا كى نفهم المطلوب لأن الكود فيه بحث عن حرف u و لا أفهم الغرض من ذلك مع الشكر