اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

طلب تعديل كود دوائر حمراء على الشهادات


الردود الموصى بها

السلام عليكم

أخوتى الأعزاء

الملف المرفق به كود لوضع الدوائر الحمراء على الشهادات

الملف بإصدارة 2010

وبه الآتى

1. الشاشة تومض 3 مرات مع طبع كل شهادة مما يؤدى إلى تهنيج البرنتر وإلا فيجب أن أطبع الشهادات شيت تلو الآخر مما يعنى أن أضغط 350 مرة على زر الطباعة لطبع 1111 شهادة

2. الأوفيس فى مكان العمل بالمدرسة 2003 والجهاز قد لا يقبل أوفيس 2010

المطلوب

تعديل الكود ليعمل على أوفيس 2003 وفى نفس الوقت محاولة تلافى عملية الوميض بالشاشة عدة مرات مع تغيير الشهادة

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

مع خالص تحياتى

كود دوائر حمراء بالشهادات 2010.rar

رابط هذا التعليق
شارك

أخي يوسف جربت الكود على 2003 و هو يعمل بطريقة جيدة

اما بالنسبة للاهتزاز فقد اضفت فقط سطرين و اعتقد انه توقف عن الاهتزاز


Sub Printno_From_To_()

Application.ScreenUpdating = False

Dim i As Integer

For i = Range("G6") To Range("I6") Step 3

If i <= Range("I6") Then

Range("K3") = i

Activewindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True

End If

Next i

Range("K3").Select

Application.ScreenUpdating = True

End Sub

رابط هذا التعليق
شارك

السلام عليكم أبو حنين

دام فضلك

ليس هذا هو الكود المقصود يا الغلا

الكود المراد التعديل عليه هو كود الدوائر الحمراء

الموجود فى حدث الشيت وليس فى الموديول

رجاء إعادة النظر فى الملف

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

للرفع

رفع الله قدركم

وبلغكم آمـــــــــــــــالكم

وجعل أعمالكم فى موازين حسناتكم

إخوانى الأعزاء

لو الأمر شديد الصعوبة إخبرونى حتى أبحث فى إتجاه آخر

ولكنى أرى الأمر هين كود يعمل جيداً على إصدارة 2010 ولا يعمل على إصدارة 2003

المطلوب تعديله ليعمل على 2003 وبالتأكيد الأمر سهل لذوى الخبرة من الأساتذة الأجلاء بالمنتدى وهم كثر

كذلك موضوع الوميض عند إستخدام كود الدوائر

أعتقد أن خبراء الأكواد ببساطة سيضيفون سطر ما فى الكود لكى يتوقف الوميض بسهولة كبيرة بالنسبة لهم

وفقكم الله

رابط هذا التعليق
شارك

الأخ الغالى ياسر بك

المطلوب أن يتم تعديل كود إضافة الدوائر بالملف المرفق بالمشاركة الأولى كالتالى

1. أن يعمل على أوفيس 2003

2. أن يتم منع الوميض الذى يحدث 3 مرات اثناء عمل الكود

ملحوظة الكود المراد تعديله موجود فى حدث الشيت وليس فى الموديول

بس كدة

رابط هذا التعليق
شارك

جرب الكود بهذا الشكل

قمت بإضافة بسيطة...

ممكن أعرف ما هي رسالة الخطأ التي تظهر لك عندما تقوم بتشغيله على أوفيس 2003 لأني بستخدم 2007؟

Private Sub Worksheet_Calculate()

Dim c As Range

Dim MyRng As Range, V As Shape

Dim G As Integer, R As Integer, d As Integer

'================================================

G = 2	  '	ÚãæÏ ÑÞã ÇáÌáæÓ

R = 15	   '	ÕÝ ÇáÏÑÌÇÊ

Set MyRng = Range("e16:p44")  ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ

'================================================

Application.ScreenUpdating = False

Application.EnableEvents = False

'==============ÍÐÝ ÇáÏæÇÆÑ ÇáÓÇÈÞÉ====================

For Each V In ActiveSheet.Shapes

If V.Top = Rows(16).Top + 1 Or V.Top = Rows(30).Top + 1 Or V.Top = Rows(44).Top + 1 Then V.Delete

Next

'================================================

For Each c In MyRng

	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 = "Û") 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

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

رابط هذا التعليق
شارك

للأسف أخى الغالى ياسر بك

لم يظبط معى الملف على أوفيس 2003 رغم أنه شغال على أوفيس 2010

طيب هل ظبط معك على أوفيس 2007 ؟؟

مرفق الملف 2003

دوائر 2003.rar

رابط هذا التعليق
شارك

الملف المرفق لم يتم تحميله جيداً

أرجو إعادة رفعه

تفضل أخى الغالى

دوائر 2003.rar

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

أستاذ / يوسف عطا

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

وأيضاً سرعة الحذف باستخدام كود أستاذ خبور خير بعد تعديله ليتناسب مع كود رسم الدوائر الخاص بى

أنظر المرفقات

يا ريت تقولى رأيك

شهادات1.rar

رابط هذا التعليق
شارك

هناك تعديل بسيط فى أول الكود ممكن حضرتك تلاحظه فى أول 3 أسطر

Sub إضافة_الدوائروالمربعات_شهادات2_نقر()

Application.ScreenUpdating = False

Application.EnableEvents = False

حذف_الدوائر_والمربعات_شهادات2_نقر

إضافة_الدوائر_شهادات2_نقر

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

Sub إضافة_الدوائر_شهادات2_نقر()

'

' إضافة_الدوائر_شهادات2_نقر ماكرو

' الماكرو مسجل ‎17/05/2012 بواسطة ‎مجدى الحاوى

'

Activewindow.Zoom = 100

ActiveSheet.Unprotect

'=====================================================

' رسم شكل بيضاوى

ActiveSheet.Shapes.AddShape(msoShapeOval, 0.75, 0.75, 36, 17).Select

'تنسيق الشكل البيضاوى

Selection.ShapeRange.Fill.Solid

Selection.ShapeRange.Fill.Transparency = 0#

Selection.ShapeRange.Line.Weight = 1.5

Selection.ShapeRange.Line.DashStyle = msoLineSolid

Selection.ShapeRange.Line.Style = msoLineSingle

Selection.ShapeRange.Line.Transparency = 0#

Selection.ShapeRange.Line.Visible = msoTrue

Selection.ShapeRange.Line.ForeColor.SchemeColor = 64

Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

Selection.ShapeRange.Fill.Visible = msoFalse

Selection.Name = "oval 1"

'=====================================================

'تحديد لشكل البيضاوى وقصه المسمى oval 1

ActiveSheet.Shapes.Range(Array("oval 1")).Select

Selection.Cut

'=====================================================

' الشهادة الأولى

' الشهادة الأولى

Dim R As Integer

'تحديد أول خلية فى مادة اللغة العربية

R = 15

Range("E16").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

Next

'=====================================================

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

' الشهادةالثانية

'تحديد أول خلية فى مادة اللغة العربية

R = 29

Range("E30").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

Next

'=====================================================

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

'=====================================================

'الشهادة الثالثة

'تحديد أول خلية فى مادة اللغة العربية

R = 43

Range("E44").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

Next

'=====================================================

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowSorting:=True, AllowFiltering:=True

'

'

End Sub

Sub حذف_الدوائر_والمربعات_شهادات2_نقر()

'

'

' كود الحذف

ActiveSheet.Unprotect

'=====================================================

' حذف الدوائر

Dim V As Shape

For Each V In ActiveSheet.Shapes

If V.Name = "oval 1" Then V.Delete

Next

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowSorting:=True, AllowFiltering:=True

End Sub

رابط هذا التعليق
شارك

بالفعل التعديل إختصر الكود وجعله أكثر سلاسة

ولكنه لا زال لا يقوم بالعمل أوتوماتيكياً

من حيث إضافة وإزالة الدوائر تلقائياً أثناء إستعراض الشهادات

خاصة مع إستخدام أسهم التقديم والتأخير للشهادات صفحة صفحة

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

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

رابط هذا التعليق
شارك

أخى حسن

أنظر إلى هذا الملف

التنقل بين الشهادات بالكتابة فى الخلية الزرقاء وليس بالأسهم والقوائم المنسدلة

ولكن عند الطبع تظهر الدوائر تلقائياً بطريقة مظبوطة سواء طبع كل الشهادات أو طبع شهادات معينة أو صفحات محددة

والمشكلة التى تواجهنى حالياً هى

1. الكود لا يعمل عند نقله لملفى الاصلى ولا أعرف السبب

2. الكود متعارض مع كود أخر فى نفس الشيت عند تفعيل الكودين

3. لازلت لم أتوصل لطريقة لوضع المربع حول درجة الطالب الراسب حكماً فى مادة ما علماً بأننى أفكر فى وضع معادلة لجلب الدرجة الأقل من 15 فى تحريرى 2 بترتيب المواد فى جدول مجاور لجدول الدرجات

فكرة الكود وضع دائرة عند عدم التحقق من صحة الرقم الموجود فى خلية الدرجة

دوائرشهادات.rar

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

  • 3 weeks later...

الملف المرسل من قبلك على الرابط

لم يعمل معي فعدلت على الأكواد عدة محاولات

حتى عمل معي على الملف الأساسي

مالأوفيس المستخدم لديك ؟

رابط هذا التعليق
شارك

أوفيس 2003

الملفان مرة أخرى مرفقان هنا

الملف الكبير مضغوط مرتين ليمكن رفعه بالمنتدى

كنترول 2 2013.rar

دوائر الشهادات نهائى.rar

رابط هذا التعليق
شارك

بعد تنزيل الملف وفك الضغط عنه تظهرلى رسالة أن الجزء الثانى من الملف مفقود

رجاء إعادة الرفع أو إرساله على الإيميل

الف شكر

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information