lord قام بنشر مارس 11, 2005 مشاركة قام بنشر مارس 11, 2005 الاساتذة الافاضل عندى ملف على الاكسل يوجد بالورقة الاولى طلبة الصف 1/1 الاعدادى والورقة الثانية طلبة الصف 1/2 وهكذا حتى عشرة ورقات هل يمكن عمل كود vb لاستخراج اعلى خمس مجاميع من عمود محدد لكل ورقة فى ملف جديد ( سوف اسميه مسبقا ) يتم فيه نقل اعلى خمس طلاب متضمن رقم الجلوس والاسم والفصل والمجموع ارجو الرد ولكم جزيل الشكر رابط هذا التعليق شارك More sharing options...
كريم قام بنشر مارس 12, 2005 مشاركة قام بنشر مارس 12, 2005 لقد شاهدت الملف لكن هناك بعض الأستفسارات لكي أحقق لك ماتريد بالضبط. 1- على أي أساس يحسب النجاح . هل على المجموع أقل من 100 أو رسوب شخص في مادة ونجاحه في المواد الأخرى فيعتبر راسب؟ 2- إذا كان مجموع الطالب الخامس مساويا مجموع الطالب السادس وقد يكون السابع أيضا فماذا تريد في هذه الحالة؟ 3- هل تريد نقل الخمسة الطلاب الأوائل إلى ملف آخر أو تريد وضعهم في نفس الملف لكن مثلا في ورقة مستقلة تكون بآخر الملف ، وأعتقد هذا الأفضل من وجهة نظري. أجب على إستفساراتي وسوف تجد الحل سريعا إنشاء الله. رابط هذا التعليق شارك More sharing options...
lord قام بنشر مارس 12, 2005 الكاتب مشاركة قام بنشر مارس 12, 2005 السلام عليكم ورحمة الله وبركاته اخى كريم اكرر شكرى لك بالنسبه للملف هذا مثال كتبته بسرعة طبعا سوف يكون الحساب على اساس ان الطالب ناجح وانا عندى ملف مجهز لذلك انا اريد اكبر خمسة بما فيهم المكرر يعنى مثلا 140، 135 ، 135، 135 ،129 وهذا مثلا اهم شى ان تكون المعادلة بسيطة بقدر الامكان بالنسبة لى يفضل ان تكون فى ملف اخر اسمه اوائل الصفوف لاننى سوف افرزة بعد ذلك لى استخرج منه اعلى عشرة على مستوى الصفوف وانا سعيد جدا بردك لاننى ارسلت هذه المشاركة من قبل ولم اجد رد فيكفينى ردك رابط هذا التعليق شارك More sharing options...
محمد حجازي قام بنشر مارس 15, 2005 مشاركة قام بنشر مارس 15, 2005 السلام عليكم ... جرب الكود التالي: Sub MySort() Dim EndRow As Long Set NewBook = Workbooks.Add With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" End With For Each MySheet In Workbooks("الصف الأول الإعدادي").Worksheets For Each MyCell In MySheet.Range("I5:I24").Cells If MySheet.Cells(MyCell.Row, 10).Value = "ناجح" Then If MyCell.Value = MySheet.Cells(5, 12).Value Or MyCell.Value = MySheet.Cells(6, 12).Value Or MyCell.Value = MySheet.Cells(7, 12).Value Or MyCell.Value = MySheet.Cells(8, 12).Value Or MyCell.Value = MySheet.Cells(9, 12).Value Then EndRow = NewBook.Sheets(1).Range("A1").CurrentRegion.Rows.Count NewBook.Sheets(1).Cells(EndRow + 1, 1).Value = MySheet.Cells(MyCell.Row, 2).Value NewBook.Sheets(1).Cells(EndRow + 1, 2).Value = MySheet.Name NewBook.Sheets(1).Cells(EndRow + 1, 3).Value = MyCell.Value End If End If Next MyCell Next MySheet With NewBook.Sheets(1) .Range(Cells(1, 1), Cells(EndRow + 1, 3)).Sort Key1:=.Range("C2"), Order1:=xlDescending End With End Sub ولكن الكود السابق يحتاج لإضافة جدول أعلى خمس علامات (في كل ورقة). جرب المرفق ، وإذا كان هذا قصدك فأخبرني لأكمل الكود (تنسيق وحفظ الجدول الجديد). بالتوفيق MySort.zip رابط هذا التعليق شارك More sharing options...
lord قام بنشر مارس 17, 2005 الكاتب مشاركة قام بنشر مارس 17, 2005 السلام عليكم ورحمة الله وبركاته شكرا استاذ محمد فعلا هو ما اريده ارجو تكملة المطلوب مع شرح بسيط للكود كما ارجو ان يوجد زر لتنفيذ الماكرو وجزاك الله خيرا رابط هذا التعليق شارك More sharing options...
محمد حجازي قام بنشر مارس 18, 2005 مشاركة قام بنشر مارس 18, 2005 السلام عليكم ... مرفق المثال معدل ويحتوي على زر أمر (كما طلبت). بالنسبة للكود ففكرته بسيطة ، وهي أنه يقوم بفحص كل خلية من المجال I5:I24 ، وذلك في كل ورقة موجودة في المصنف " الصف الأول الإعدادي " ويرى إذا كانت القيمة الموجودة فيها من ضمن أعلى خمس قيم وذلك طبعاً بعد فحص الخلية المقابلة لها في العامود J و التأكد من أنها تحتوي على الشرط "ناجح" ، فإذا كان ذلك محقق فإنه يضيف معلومات هذا الطالب في الملف الجديد الذي تم إنشاءه وفي النهاية فإنه يقوم بفرز المعلومات في الملف الجديد وينسقها ضمن جدول معين. معذرة على الشرح السريع وذلك لأني مشغول هذه الأيام ولا أملك الكثير من الوقت . على أيه حال فإنني أتمني أن يعجبك التنسيق الذي وضعته لك في الملف الجديد الذي سوف يحفظ في نفس مسار الملف القديم وتحت اسم (أوائل الصفوف) ، وكما يجب الانتباه إلى أن الملف الجديد سوف يخزن فوق أي ملف له نفس الاسم وذلك دون الرجوع إليك ، وإذا كنت تريد ظهور رسالة تخيرك بين الحفظ فوق الملف القديم أو لا فأخبرني لأشرح لك طريقة تعديل ذلك. بالتوفيق NewMySort.zip رابط هذا التعليق شارك More sharing options...
lord قام بنشر مارس 18, 2005 الكاتب مشاركة قام بنشر مارس 18, 2005 تعديل جميل جداجدا اشكرك استاذى العزيز ذادك الله من علمه وفضله كل ما اريده الان هو رسالة الحفظ وهى مهمة جدا كما اريد ان اعرف كيف اعدله لكى يظهر لى رقم الجلوس انا مقدر انشغالك لكن اطمع فى المذيد وشكرا رابط هذا التعليق شارك More sharing options...
محمد حجازي قام بنشر مارس 19, 2005 مشاركة قام بنشر مارس 19, 2005 (معدل) السلام عليكم ... أنا أعرف حق المعرفة بأن أسلوب إعطاء الحلول الجاهزة هو أسلوب عقيم ولا يفيد المتلقين بصورة فعالة ، و كان من الأجدر بي شرح كل كود أقوم بكتابته :) ، ولكن المشاغل لا تترك لي وقتاً ألتقط به أنفاسي ، و وعد مني لأعضاء هذا المنتدى الكرام بتغيير أسلوب تعاملي مع الأسئلة في المستقبل (قدر المستطاع). الآن سوف أشرح الكود وأتحدث في الوقت نفسه عن التغييرات التي يريدها الأخ لورد في كود المرفق. الكود هو التالي: Sub MySort() Dim EndRow As Long Dim MyPath As String Dim NumberSheets() As Integer Dim i As Integer Application.ScreenUpdating = False Set NewBook = Workbooks.Add With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" End With For Each MySheet In Workbooks("الصف الأول الإعدادي").Worksheets For Each MyCell In MySheet.Range("I5:I24").Cells If MySheet.Cells(MyCell.Row, 10).Value = "ناجح" Then If MyCell.Value = MySheet.Cells(5, 12).Value Or MyCell.Value = MySheet.Cells(6, 12).Value Or MyCell.Value = MySheet.Cells(7, 12).Value Or MyCell.Value = MySheet.Cells(8, 12).Value Or MyCell.Value = MySheet.Cells(9, 12).Value Then EndRow = NewBook.Sheets(1).Range("A1").CurrentRegion.Rows.Count NewBook.Sheets(1).Cells(EndRow + 1, 1).Value = MySheet.Cells(MyCell.Row, 2).Value NewBook.Sheets(1).Cells(EndRow + 1, 2).Value = MySheet.Name NewBook.Sheets(1).Cells(EndRow + 1, 3).Value = MyCell.Value End If End If Next MyCell Next MySheet With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) .Sort Key1:=NewBook.Sheets(1).Range("C2"), Order1:=xlDescending .Borders().LineStyle = xlContinuous .Borders().Weight = xlThin .Borders().ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireColumn.AutoFit .Interior.ColorIndex = 34 End With MyPath = Workbooks("الصف الأول الإعدادي").Path & "\أوائل الصفوف" ReDim NumberSheets(2 To NewBook.Worksheets.Count) For i = 2 To NewBook.Worksheets.Count NumberSheets(i) = i Next i Application.DisplayAlerts = False With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub ولنشرح الكود خطوة خطوة: Dim EndRow As Long Dim MyPath As String Dim NumberSheets() As Integer Dim i As Integer في الأسطر السابقة قمنا بتعريف المتغيرات كلٌ حسب طبيعة البيانات التي يحتاجها. Application.ScreenUpdating = False هنا ألغينا خاصية تحديث الشاشة ، وذلك حتى لا تبدو لنا التغييرات التي تحدث في الملف المنشئ (أثناء تنفيذ الكود) هذا من جهة ، ولتسريع الكود من جهة أخرى. Set NewBook = Workbooks.Add هنا قمنا بإنشاء مصنف جديد وأسندنا مرجعه في المتغير NewBook. With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" End With هنا قمنا بتسمية أول ورقة في المصنف الجديد باسم (أوائل الصفوف) وقمنا بتسمية الخلايا A1 ، B1 ، C1 الموجودة في الورقة الأولى بـ ( اسم الطالب ، الفصل ، مجموع العلامات ) على الترتيب. ولإضافة رقم الجلوس ما عليك سوى إضافة سطر أخر تقوم فيه بتسمية الخلية D1 بـ أرقام الجلوس ، وذلك كما يلي: With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" .Cells(1, 4).Value = "أرقام الجلوس" End With ويمكنك تغيير هذا الترتيب بتغيير الأرقام الموجودة في الهدف Cells كما تريد. For Each MySheet In Workbooks("الصف الأول الإعدادي").Worksheets هنا توجد لدينا حلقة تكرارية تسند في كل دورة مرجع لورقة معينة من المصتف في المتغير MySheet وذلك إلى أن تنتهي الأوراق الموجودة في مصنف "الصف الأول الإعدادي". For Each MyCell In MySheet.Range("I5:I24").Cells هنا توجد لدينا حلقة تكرارية تسند في كل دورة مرجع لخلية معينة من المجال I5:I24 الموجود داخل الورقة MySheet في المتغير MyCell وذلك إلى أن تنتهي الخلايا الموجودة في هذا المجال. If MySheet.Cells(MyCell.Row, 10).Value = "ناجح" Then هنا يتم اختبار الخلية المقابلة للخلية MyCell في العامود العاشر ومعرفة إذا كانت تحقق الشرط "ناجح" فإذا كان الشرط محقق يتم الانتقال للشرط الذي يليه. If MyCell.Value = MySheet.Cells(5, 12).Value Or MyCell.Value = MySheet.Cells(6, 12).Value Or MyCell.Value = MySheet.Cells(7, 12).Value Or MyCell.Value = MySheet.Cells(8, 12).Value Or MyCell.Value = MySheet.Cells(9, 12).Value Then هنا يتم اختبار القيمة الموجودة في الخلية MyCell فإذا كانت من ضمن العلامات الخمس الأوائل فإنه يتم الانتقال للسطر التالي. EndRow = NewBook.Sheets(1).Range("A1").CurrentRegion.Rows.Count هنا يتم إسناد رقم آخر سطر من نطاق البيانات الموجود في ورقة أوائل الصفوف وفي الملف الجديد في المتغير EndRow ، والهدف من هذا السطر هو الحيلولة دون الكتابة فوق البيانات القديمة. NewBook.Sheets(1).Cells(EndRow + 1, 1).Value = MySheet.Cells(MyCell.Row, 2).Value هنا يتم وضع القيمة المقابلة للخلية MyCell في العامود الثاني B من الملف القديم (عامود الاسم) في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود A(عامود اسم الطالب). NewBook.Sheets(1).Cells(EndRow + 1, 2).Value = MySheet.Name هنا يتم وضع اسم الورقة MySheet من الملف القديم في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود B(عامود الفصل). NewBook.Sheets(1).Cells(EndRow + 1, 3).Value = MyCell.Value هنا يتم وضع قيمة الخلية MyCell من الملف القديم في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود C(عامود مجموع العلامات). وبفرض أن رقم الجلوس موجود في العمود K من الملف القديم ، فيجب عليك إضافة السطر التالي: NewBook.Sheets(1).Cells(EndRow + 1, 4).Value = MySheet.Cells(MyCell.Row, 11).Value هنا يتم وضع القيمة المقابلة للخلية MyCell في العامود الحادي عشر K من الملف القديم (عامود رقم الجلوس) في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود D(عامود رقم الجلوس). With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) .Sort Key1:=NewBook.Sheets(1).Range("C2"), Order1:=xlDescending .Borders().LineStyle = xlContinuous .Borders().Weight = xlThin .Borders().ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireColumn.AutoFit .Interior.ColorIndex = 34 End With هنا قمنا ببعض التعديلات على جدول البيانات الناتج ، وهي على الترتيب: - القيام بفرز تنازلي للبيانات بالاعتماد على عامود مجموع العلامات. - إحاطة خلايا الجدول بحدود على هيئة خطوط متصلة. - تحديد خط التحديد على أنه خط مفرد رفيع. - تحديد لون خط التحديد على أنه تلقائي. - عمل محاذاة أفقية لبيانات الجدول. - عمل محاذاة عاموديه لبيانات الجدول. - احتواء مناسب لبيانات الجدول (تغيير عرض الأعمدة لتستوعب البيانات الموجودة). - تعبئة خلايا الجدول باللون 34. وهنا يجب الملاحظة على ضرورية توسيع حيز تأثير الكود السابق في حالة استخدام أربعة أعمدة ، وذلك عن طريق تغيير السطر: With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) إلى السطر: With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 4)) نتابع شرح الكود... MyPath = Workbooks("الصف الأول الإعدادي").Path & "\أوائل الصفوف" هنا قمنا بإسناد مسار الملف الجديد في المتغير MyPath (وذلك لاستخدامه لا حقاً عند حفظ الملف) ، وذلك بتسمية المسار الجديد بالاسم "أوائل الصفوف" ووضعه في نفس مسار الملف القديم. ReDim NumberSheets(2 To NewBook.Worksheets.Count) For i = 2 To NewBook.Worksheets.Count NumberSheets(i) = i Next i هنا قمنا بوضع مراجع الأوراق الزائدة في الملف الجديد في مصفوفة ديناميكية (وذلك لاستخدامها لاحقاً في حذف الأوراق الزائدة). Application.DisplayAlerts = False هنا قمنا بإلغاء خاصية إرسال الرسائل للمستخدم. With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With هنا قمنا ببعض التعديلات على الملف الجديد ، وهي بالترتيب: - تلوين ترويسة الجدول باللون 35. - حذف الأوراق الزائدة (التي توجد مراجعها داخل المصفوفة NumberSheets) - حفظ الملف الجديد بالمسار الموجود في المتغير MyPath. - إغلاق الملف الجديد. Application.DisplayAlerts = True Application.ScreenUpdating = True إعادة الخاصيتين السابقتين للعمل. وهنا يوجد تساؤل ، لماذا ألغينا الخاصية DisplayAlerts؟ لقد قمنا بإلغاء هذه الخاصية من أجل تجاهل الرسالة التي تخبرنا بتأكيد حذف الأوراق الزائدة في الملف الجديد وبالرسالة التي تخبرنا بتأكيد الحفظ فوق ملف قديم موجود مسبقاً. ولكن ماذا لو أردنا تجاهل رسالة تأكيد حذف الأوراق الزائدة مع الإبقاء على رسالة تأكيد التسجيل فوق ملف قديم؟ الحل بسيط ، ويكمن بتعديل الكود: Application.DisplayAlerts = False With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True إلى الكود: With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 Application.DisplayAlerts = False .Sheets(NumberSheets).Delete Application.DisplayAlerts = True .SaveAs Filename:=MyPath .Close End With Application.ScreenUpdating = True بالتوفيق تم تعديل مارس 19, 2005 بواسطه محمد حجازي رابط هذا التعليق شارك More sharing options...
lord قام بنشر مارس 19, 2005 الكاتب مشاركة قام بنشر مارس 19, 2005 بارك الله فيك وشكرا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها