إنشاء تقرير وحفظه في ملف مستقل

[lord]

الاساتذة الافاضل

عندى ملف على الاكسل

يوجد بالورقة الاولى طلبة الصف 1/1 الاعدادى

والورقة الثانية طلبة الصف 1/2 وهكذا حتى عشرة ورقات

هل يمكن عمل كود vb لاستخراج اعلى خمس مجاميع من عمود محدد لكل ورقة

فى ملف جديد ( سوف اسميه مسبقا )

يتم فيه نقل اعلى خمس طلاب متضمن

رقم الجلوس والاسم والفصل والمجموع

ارجو الرد

ولكم جزيل الشكر

[كريم]

لقد شاهدت الملف لكن هناك بعض الأستفسارات لكي أحقق لك ماتريد بالضبط.

1- على أي أساس يحسب النجاح . هل على المجموع أقل من 100 أو رسوب شخص في مادة ونجاحه في المواد الأخرى فيعتبر راسب؟

2- إذا كان مجموع الطالب الخامس مساويا مجموع الطالب السادس وقد يكون السابع أيضا فماذا تريد في هذه الحالة؟

3- هل تريد نقل الخمسة الطلاب الأوائل إلى ملف آخر أو تريد وضعهم في نفس الملف لكن مثلا في ورقة مستقلة تكون بآخر الملف ، وأعتقد هذا الأفضل من وجهة نظري.

أجب على إستفساراتي وسوف تجد الحل سريعا إنشاء الله.

[lord]

السلام عليكم ورحمة الله وبركاته اخى كريم

اكرر شكرى لك

بالنسبه للملف هذا مثال كتبته بسرعة

طبعا سوف يكون الحساب على اساس ان الطالب ناجح وانا عندى ملف مجهز لذلك

انا اريد اكبر خمسة بما فيهم المكرر يعنى مثلا 140، 135 ، 135، 135 ،129

وهذا مثلا

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

بالنسبة لى يفضل ان تكون فى ملف اخر اسمه اوائل الصفوف

لاننى سوف افرزة بعد ذلك لى استخرج منه اعلى عشرة على مستوى الصفوف

وانا سعيد جدا بردك

لاننى ارسلت هذه المشاركة من قبل ولم اجد رد

فيكفينى ردك

[محمد حجازي]

السلام عليكم ...

جرب الكود التالي:

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

[lord]

السلام عليكم ورحمة الله وبركاته

شكرا استاذ محمد

فعلا هو ما اريده

ارجو تكملة المطلوب

مع شرح بسيط للكود

كما ارجو ان يوجد زر لتنفيذ الماكرو

وجزاك الله خيرا

[محمد حجازي]

السلام عليكم ...

مرفق المثال معدل ويحتوي على زر أمر (كما طلبت).

بالنسبة للكود ففكرته بسيطة ، وهي أنه يقوم بفحص كل خلية من المجال I5:I24 ، وذلك في كل ورقة موجودة في المصنف " الصف الأول الإعدادي " ويرى إذا كانت القيمة الموجودة فيها من ضمن أعلى خمس قيم وذلك طبعاً بعد فحص الخلية المقابلة لها في العامود J و التأكد من أنها تحتوي على الشرط "ناجح" ، فإذا كان ذلك محقق فإنه يضيف معلومات هذا الطالب في الملف الجديد الذي تم إنشاءه وفي النهاية فإنه يقوم بفرز المعلومات في الملف الجديد وينسقها ضمن جدول معين.

معذرة على الشرح السريع وذلك لأني مشغول هذه الأيام ولا أملك الكثير من الوقت .

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

بالتوفيق

NewMySort.zip

[lord]

تعديل جميل جداجدا

اشكرك استاذى العزيز

ذادك الله من علمه وفضله

كل ما اريده الان هو رسالة الحفظ وهى مهمة جدا

كما اريد ان اعرف كيف اعدله لكى يظهر لى رقم الجلوس

انا مقدر انشغالك

لكن اطمع فى المذيد

وشكرا

[محمد حجازي]

السلام عليكم ...

أنا أعرف حق المعرفة بأن أسلوب إعطاء الحلول الجاهزة هو أسلوب عقيم ولا يفيد المتلقين بصورة فعالة ، و كان من الأجدر بي شرح كل كود أقوم بكتابته :) ، ولكن المشاغل لا تترك لي وقتاً ألتقط به أنفاسي ، و وعد مني لأعضاء هذا المنتدى الكرام بتغيير أسلوب تعاملي مع الأسئلة في المستقبل (قدر المستطاع).

الآن سوف أشرح الكود وأتحدث في الوقت نفسه عن التغييرات التي يريدها الأخ لورد في كود المرفق.

الكود هو التالي:

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 بواسطه محمد حجازي

[lord]

بارك الله فيك

وشكرا