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

كود اضافة و حذف دوائر


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

  • الردود 88
  • Created
  • اخر رد

Top Posters In This Topic

السلام عليكم

الاخ قصي

اسم الورقة غير صحيح

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       RemoveCircles1
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub

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

كتر الله من خيرك

اول مرة انقل كود الى ملف من عندي بفضل الله ثم توجيهاتك

اقصد كود الدوائر

اما كود الترحيل بصراحة انا مش عارف

تشكر ياباشا

الملف به بعض الطلبات التي تحتاج الى ابداعاتك

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

السلام عليكم

كود الحذف يحذف 1377 دائرة سريعا

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

لجميع الخلايا

=AND(ISNUMBER(Q$9);$B10>0;OR(Q10<Q$9;Q10="غ";Q10="غـ"))
وتم تضبيط كود الترحيل للناجحين ودور ثاني
Sub KH_Start()
On Error Resume Next
Dim M As Integer, N As Integer, X As Integer, R As Integer
Sheet5.Range("A10:CX1000").Clear
Sheet7.Range("A10:CX1000").Clear
M = 10     '    اول صف لورقة الناجحين
N = 10     '    اول صف لورقة دور ثان
Application.ScreenUpdating = False
With Sheet1
    X = .Range("A" & .Rows.Count).End(xlUp).Row
    For R = 10 To X
        If .Range("CX" & R) = "ناجح" Then
            .Range("A" & R).Resize(1, 102).Copy
            KH_Paste Sheet7, M
            M = M + 1
        End If
        If .Range("CX" & R) = "دور ثان" Then
            .Range("A" & R).Resize(1, 102).Copy
            KH_Paste Sheet5, N
            N = N + 1
        End If
    Next R
End With
Application.ScreenUpdating = True
MsgBox "تم ترحيل   " & M - 10 & "   طالب ناجح" & Chr(10) & Chr(10) & "تم ترحيل   " & N - 10 & "   طالب دور ثاني", vbMsgBoxRight, "الحمدلله"
End Sub
Sub KH_Paste(MySheet As Worksheet, KRow As Integer)
On Error Resume Next
With MySheet
    .Range("A" & KRow).PasteSpecial xlPasteValues
    .Range("A" & KRow).PasteSpecial xlPasteFormats
    .Range("A" & KRow) = KRow - 9
End With
Application.CutCopyMode = False
End Sub

تفضل المرفق

________________________________1.rar

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

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

ــــــــــــــ
نريد معادلة لتخرج لنا الناجح ومن عنده دور تان توضع في العمود cx10
وتكون شروطها كالآتي
اذا كان الطالب ليس غائبا في امتحان آخر العام ودرجته في امتحان اخر العام اكبر او تساوي الدرجة الموجودة في نفس عمود امتحان اخر العام
والصف التاسع..
وفي نفس الوقت تكون درجة الطالب في مجموع الفصلين اكبر من او تساوي الدرجة الموجودة بالصف التاسع في عمود مجموع الفصلين
في هذه الحالة يكون الطالب ناجح وغير ذلك له دور تان

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

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

مفيده جدا جدا .. ولكن عيزة جزئية من اضافاتك لهذا التنسيق

مثال .. لوان طالب حصل في مادة على مجموع الفصلين على 81 درجة مثلا وكان غايب في اتحان آخر العام او درجة امتحانه في اخر العام اقل من النهايه الصغرى لمادة الامتحان في اخر العام

........ في مثل هذه الحاله يجب ان يوضع دائره او تنسيق يعني الطالب له دور تان

كود الحذف يحذف 1377 دائرة سريعا

سرعه ملحوظة كتر الله من خيرك

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

السلام عليكم

الاخ / قصي

ممكن ملف فيه بيانات اقرب الى الواقع ( بالنسبة للدرجات)

حتى نستطيع التطبيق بشكل مثالي

وبالنسبة للشهادات

ممكن رقم عمود المادة

مثلا نشاطات من اي عمود توخذ؟؟؟

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

السلام عليكم

تطبيق التنسيق الجديد

وايضا باضافة الدوائر

=========================

مع استخراج حالة الطالب و مواد دور ثاني

عند اضافتك للدوائر

=========================

تم التطبيق على ثلاث مواد(عربي /انجليزي/ رياضيات)

هل هناك مواد اخرى؟؟؟

=========================

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

انظر الى تنسيق الشهادة

او غير ما تريده حسب ما تريد

=========================

اريد اجابات بالتفصيل الممل

لو تكرمت

________________________________2.rar

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

الاستاذ الجهبذ / عبد الله

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

نقله نوعية في كود لدوائر الحمراء

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

التنسيق الشرطي فاق الوصف

عدد الشهادات في ورقة الطباعه 3

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

الأستاذ العلامه الكبير/ خبور

السلام عليكم

هل بمكن تطبيق كود الدوائر

على ورقة الشهادة؟؟

حيث أننى طبقتها على ورقة

شيت ولكن حاولت على الشهادة

ولم أفلح!!!!!!

___________________________1.rar

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

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

بعد غياب طويل أود أن أشكر الجهود المبذولة في ها الموضوع, لقد أثار فضولي الساعة الالكترونية الموجودة في الفايل هل من أحد يدلني على كيفية القيام بها في الاكسل؟

مشكورة مقدما

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

السلام عليكم

ISRA

انظر الى الرابط:

بخصوص ساعات بصيغة الفلاش

http://www.officena.net/ib/index.php?showtopic=27879&hl=

=======================================

الاخ / ابن النيل ---------------حفظه الله

تفضل كود اضافة الشهادات مع الدوائر

مع ضبط اعدادات تحضير الشهادات للطباعة

شهادة في كل ورقة

Sub KH_ADD_S()
Dim MyRng As Range, MyCell As Range
Dim X As Integer, R As Integer, Y As Integer
Set MyRng = ورقة1.Range("A12:DL51")
Set MyCell = Range("نموذج_الشهادة")
KH_Clear
Application.ScreenUpdating = False
X = 25
MyCell.Copy
For R = 1 To MyRng.Rows.Count - 1
    Range("B" & X).PasteSpecial xlPasteAll
    X = X + 22
Next R
X = 12
With MyRng
    For R = 1 To .Rows.Count
        Range("F" & X) = .Range("H" & R)
        Range("P" & X) = .Range("B" & R)
        Range("E" & X + 7) = .Range("DK" & R)
        Range("J" & X + 7) = .Range("DL" & R)
        Range("D" & X + 5).RowHeight = 33
        For C = 4 To 19
            .Cells(R, Cells(1, C)).Copy
            Cells(X + 5, C).Select
            ActiveSheet.Paste
            Selection.PasteSpecial xlPasteValues
        Next C
        X = X + 22
   Next R
   With ActiveSheet
        Y = .UsedRange.Rows.Count
        .PageSetup.PrintArea = "$B$3:$T$" & Y
   End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
هذا كود حذف الدوائر والشهادات
Sub KH_Clear()
Dim shp As Shape, Y As Integer
Application.ScreenUpdating = False
    With ActiveSheet
        .Range("F12:L12,P12:Q12,D17:S17,E19:H19,J19:S20").ClearContents
        Y = .UsedRange.Rows.Count + 25
        .Rows("25:" & Y).Delete
        .PageSetup.PrintArea = Range("نموذج_الشهادة").Address
    End With
    
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete
    Next shp
    
    ActiveWindow.ScrollRow = 1
End Sub

تفضل المرفق

___________________________1.rar

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

كتر الله من خيرك يا استاذ خبور

التنسيق حلو حلو والدوائر روعه كنا منتظرينها من زمان

التغيير في الشهادة

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

والمجموع الكلي هاتبقى التقدير العام

كتر الله من خيرك

الاورف التانيه ممكن تملاها

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

والكشوف التانية على ورق ايه فور

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

السلام عليكم

ISRA

انظر الى الرابط:

بخصوص ساعات بصيغة الفلاش

http://www.officena.net/ib/index.php?showtopic=27879&hl=

=======================================

الاخ / ابن النيل ---------------حفظه الله

تفضل كود اضافة الشهادات مع الدوائر

مع ضبط اعدادات تحضير الشهادات للطباعة

شهادة في كل ورقة

Sub KH_ADD_S()
Dim MyRng As Range, MyCell As Range
Dim X As Integer, R As Integer, Y As Integer
Set MyRng = ورقة1.Range("A12:DL51")
Set MyCell = Range("نموذج_الشهادة")
KH_Clear
Application.ScreenUpdating = False
X = 25
MyCell.Copy
For R = 1 To MyRng.Rows.Count - 1
    Range("B" & X).PasteSpecial xlPasteAll
    X = X + 22
Next R
X = 12
With MyRng
    For R = 1 To .Rows.Count
        Range("F" & X) = .Range("H" & R)
        Range("P" & X) = .Range("B" & R)
        Range("E" & X + 7) = .Range("DK" & R)
        Range("J" & X + 7) = .Range("DL" & R)
        Range("D" & X + 5).RowHeight = 33
        For C = 4 To 19
            .Cells(R, Cells(1, C)).Copy
            Cells(X + 5, C).Select
            ActiveSheet.Paste
            Selection.PasteSpecial xlPasteValues
        Next C
        X = X + 22
   Next R
   With ActiveSheet
        Y = .UsedRange.Rows.Count
        .PageSetup.PrintArea = "$B$3:$T$" & Y
   End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
هذا كود حذف الدوائر والشهادات
Sub KH_Clear()
Dim shp As Shape, Y As Integer
Application.ScreenUpdating = False
    With ActiveSheet
        .Range("F12:L12,P12:Q12,D17:S17,E19:H19,J19:S20").ClearContents
        Y = .UsedRange.Rows.Count + 25
        .Rows("25:" & Y).Delete
        .PageSetup.PrintArea = Range("نموذج_الشهادة").Address
    End With
    
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete
    Next shp
    
    ActiveWindow.ScrollRow = 1
End Sub

تفضل المرفق

]حاجه ولا أروع أنت مبدع وفنان وإيه تانى مش عارف!!!!!!!!!!!!!!!

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

السلام عليكم

الاستاذ الغالى/ خبور بك خير

بعد ما قمت بزيادة عدد الطلاب

فى الشيت حسب مدرستى

حذف الدوائر أصبح ثقيل جداً

يكاد لا يعمل وكذلك الشهادات

هل من حل !!!! جعلك الله عوناً

للغلابه اللى زينا؟؟؟؟؟

___________________________1.rar

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

السلام عليكم

الاخ /ابن النيل--------------حفظه الله

هل ستحتاج في عملك الى اضافة

7500 دائرة

اعمل بيانات اقرب الى الواقع

حتى تتاكد بشكل قطعي

=============

الاخ /قصي--------------حفظه الله

تم عمل الشهادات

وكشوفات الناجحين ودورثاني

راجع المرفق

________________________________3.rar

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

السلام عليكم

الاخ /قصي--------------حفظه الله

تم عمل الشهادات

وكشوفات الناجحين ودورثاني

راجع المرفق

________________________________3.rar

=============================================

الاخ /ابن النيل--------------حفظه الله

هل ستحتاج في عملك الى اضافة

7500 دائرة

اعمل بيانات اقرب الى الواقع

حتى تتاكد بشكل قطعي

علم ياباشا

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

حفظك الله ورعاك ايها الاستاذ الكبير / عبد الله

عمل ولاأروع :clapping::clapping:

ولكننا نتعشم في كرمك في

** يضاف الدوائر الى الشهادات

** في الشهادات نريد فصل شهادات الناجحين لوحدها ثم شهادات الدور التاني لوحدها

** في الشهادات مكتوب فيها ( له دور ثانن ) نريد زيادة حرف الجر في فتصبح ( له دور ثان في ) ...ـ

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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



×
×
  • اضف...

Important Information