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

عمل الشهادات المدرسية 4 .. المرجع

ناصر سعيد

بواسطه ناصر سعيد
في منتدى الاكسيل Excel

 مشاركة

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

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

بسم الله الرحمن الرحيم

احبابنا في الله

ادعو الله ان تكونوا بخير يارب

هذا ملف به كود  واحد خاص باخراج شهادات الطلاب  وما أسهله

يستطيع ان يستجلب

=====

كل انواع الشهادات المطلوبه

الكود للنابغه ساجده العزاوي من العراق

وتعديل المحترم ذائع الصيت بن علية حاجي من الجزائر

حفظهم الله ورعاهم

طريقه الاستفاده من هذا الملف

افتح هذا الملف

اضغط على زر ALT وانت ماتزال ضاغطا

اضغط على F11

سيتم فتح محرر الاكواد .. ستجد امامك موديولات بها الاكواد

دبل كليك على اول موديول

ثم اضغط من لوحة المفاتيح على ALT  +SHEFT 

لتكون اللغه هي العربيه

منعا لظهور اللغه العربيه بشكل طلاسم

اجعل مؤشر الماوس في الكود  ثم اضغط  CTRL +A 

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

ثم    CTRL+C  ليتم النسخ

=====

** افتح ملفك وافتح محرر الاكواد كما اشرنا  سابقا

** ومن قائمه محرر الاكواد التي فتحت امامك

** اختر Insert  واختر منها Module

** ثم ضع المؤشر في  Module

** والصق الكود

==========

ماهي التغييرات التي تحدثها في الكود حتى يكون صالحا للاستعمال ؟

**  غير اسم صفحه مصدر البيانات

**  غير اسم صفحة الشهادات

**  غير رقم عمود المعيار

**  غير رقم خليه رقم الجلوس لو غيرت موقعها

=========

احمد الله وادعو لكل من له بصمه في اخراج هذا العمل بالخير

يكفي جملة

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

الشهادات ذات الثلاثه معايير

في الخليه R1 نكتب بدايه الصف الذي نريد الشهادات منه

في الخليه S1 نكتب نهايه الصف الذي نريد الشهادات اليه

===

و في الخليه R7 نكتب كلمه (نا ) او ( دور )

وفي الخليه S7 نكتب ( ول ) اختصار كلمه ولد

او نكتب ( بن ) اختصار كلمه بنت

وفي الخليه T7 نكتب الفصل (3/1 ) مثلا

وهكذا نكون استطعنا ان نستدعي شهادات الاولاد الناجحين في فصل معين في مدى معين

او الاولاد اللي عندهم دور تان في فصل معين

او البنات الناجحين في فصل معين

او البنات اللي عندهم دور تان في فصل معين وفي مدى معين

**************

يكفي جملة

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

 

 

  

 

كود الشهادات المرجع.rar

*****************************

وتعديل المحترم ذائع الصيت بن علية حاجي من الجزائر

تم بناء على متطلبات جديده في الكود

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر 
Sub اربعشهادات_بثلاث_معايير()
'هذا الكود للنابغه ساجده العزاوي
' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه
'تم في اكتوبر 2017
'كمعطيات المحترم ابو أحمد محمدي
'تم التعديل على الكود لمتطلبات جديده بواسطه المحترم ذائع الصيت بن علية حادجي الجزائري
'تم بناء على متطلبات جديده في الكود
'الهدف من الكود هو استخراج الشهادات
'كل 3 شهادات في صفحه واحدة
'بثلاثة معايير
            '======================
 Dim SHEHADA As Worksheet, DATA As Worksheet
 Dim myArray, targt1, targt2, targt3 As String
 Dim X, Y, Z, U, V As Long
    'اسم صفحة المصدر
    Set DATA = Worksheets("رصد الترم الثانى")
    
     'اسم صفحة الهدف
    Set SHEHADA = Worksheets("4شهادات بثلاث معايير")
            '======================
  ' targt1 = "ناج*"
  ' targt2 = "ول*"
  ' targt3 = "5/1"
    targt1 = SHEHADA.Range("R7").Value & "*"
    targt2 = SHEHADA.Range("S7").Value & "*"
    targt3 = SHEHADA.Range("T7").Value & "*"
            '======================
c = 0
Application.ScreenUpdating = False
lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row   'اخر صف به بيانات

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  X = SHEHADA.Range("T1").Value
  Y = SHEHADA.Range("R1").Value
  Z = SHEHADA.Range("S1").Value
  U = IIf(X = 1, 7, Y)
  V = IIf(X = 1, lr, Z)

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'هذا السطر في حال كل الشهادات أو شهادات محددة
For i = U To V
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
  If DATA.Cells(i, 101) Like targt1 & "*" _
 And DATA.Cells(i, 104) Like targt2 & "*" _
 And DATA.Cells(i, 103) Like targt3 & "*" _
 And c = 0 Then
 
     Range("M3") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 1 Then
    
    Range("M19") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 2 Then
    
    Range("M35") = DATA.Cells(i, 2)
            c = c + 1
            '======================

ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 3 Then
    
   SHEHADA.Range("M51") = DATA.Cells(i, 2)
            c = c + 1
            '======================
    
            End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 If i = V And c = 4 Then SHEHADA.Range("a1:p63").PrintOut: Exit For
 If i = V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut: Exit For
 If i = V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut: Exit For
 If i = V And c = 1 Then SHEHADA.Range("a1:p15").PrintOut: Exit For
 If i < V And (Range("M19") = "" Or Range("M35") = "" Or SHEHADA.Range("M51") = "") Then GoTo 1
 If i < V And c = 4 Then SHEHADA.Range("a1:P63").PrintOut
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    c = 0
    
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
     SHEHADA.Range("M35") = ""
     SHEHADA.Range("M51") = ""
    
1:
   Next i
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
     SHEHADA.Range("M35") = ""
     SHEHADA.Range("M51") = ""
  Application.ScreenUpdating = True
End Sub

جزاهم الله كل خير وبارك فيهم يارب ..

كل من كانت له بصمه في هذا الملف

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر 
Sub ثلاثة_معايير()
'هذا الكود للنابغه ساجده العزاوي
' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه
'تم في اكتوبر 2017
'كمعطيات المحترم ابو أحمد محمدي
'تم التعديل على الكود لمتطلبات جديده بواسطه المحترم ذائع الصيت بن علية حادجي الجزائري
'تم بناء على متطلبات جديده في الكود
'الهدف من الكود هو استخراج الشهادات
'كل 3 شهادات في صفحه واحدة
'بثلاثة معايير
            '======================
 Dim SHEHADA As Worksheet, DATA As Worksheet
 Dim myArray, targt1, targt2, targt3 As String
 Dim X, Y, Z, U, V As Long
    'اسم صفحة المصدر
    Set DATA = Worksheets("رصد الترم الثانى")
    
     'اسم صفحة الهدف
    Set SHEHADA = Worksheets("3 شهادات ب3 معايير")
            '======================
  ' targt1 = "ناج*"
  ' targt2 = "ول*"
  ' targt3 = "5/1"
    targt1 = SHEHADA.Range("R7").Value & "*"
    targt2 = SHEHADA.Range("S7").Value & "*"
    targt3 = SHEHADA.Range("T7").Value & "*"
            '======================
c = 0
Application.ScreenUpdating = False
lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row   'اخر صف به بيانات

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  X = SHEHADA.Range("T1").Value
  Y = SHEHADA.Range("R1").Value
  Z = SHEHADA.Range("S1").Value
  U = IIf(X = 1, 7, Y)
  V = IIf(X = 1, lr, Z)

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'هذا السطر في حال كل الشهادات أو شهادات محددة
For i = U To V
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
  If DATA.Cells(i, 101) Like targt1 & "*" _
 And DATA.Cells(i, 104) Like targt2 & "*" _
 And DATA.Cells(i, 103) Like targt3 & "*" _
 And c = 0 Then
 
     Range("M3") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 1 Then
    
    Range("M19") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 2 Then
    
    Range("M35") = DATA.Cells(i, 2)
            c = c + 1
            '======================

'ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 3 Then
    
  ' SHEHADA.Range("M51") = DATA.Cells(i, 2)
           ' c = c + 1
            '======================
    
            End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'If i = V And c = 4 Then SHEHADA.Range("a1:p63").PrintOut: Exit For
 If i = V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut: Exit For
 If i = V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut: Exit For
 If i = V And c = 1 Then SHEHADA.Range("a1:p15").PrintOut: Exit For
 If i < V And (Range("M19") = "" Or Range("M35") = "") Then GoTo 1
 If i < V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     
     c = 0
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
     SHEHADA.Range("M35") = ""
   ' SHEHADA.Range("M51") = ""
    
1:
   Next i
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
     SHEHADA.Range("M35") = ""
   ' SHEHADA.Range("M51") = ""
   Application.ScreenUpdating = True
End Sub

الهدف من الكود هو استخراج الشهادات
'كل  ثلاث 3 شهادات في صفحه واحدة
'بثلاثة معايير

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر 
Sub بمعيارين()
'   هذا الكود للنابغه ساجده العزاوي
' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه
'تم في اكتوبر 2017
'كمعطيات المحترم ابو أحمد محمدي
'الهدف من الكود هو استخراج الشهادات
'كل شهادتين في صفحه واحدة
'بثلاث معايير
            '======================
 Dim SHEHADA As Worksheet, DATA As Worksheet
 Dim myArray, targt1, targt2, targt3 As String
 Dim X, Y, Z, U, V As Long
    'اسم صفحة المصدر
    Set DATA = Worksheets("رصد الترم الثانى")
    
     'اسم صفحة الهدف
    Set SHEHADA = Worksheets("شهادتين")
            '======================
  ' targt1 = "ناج*"
  ' targt2 = "ول*"
  ' targt3 = "5/1"
    targt1 = SHEHADA.Range("R7").Value & "*"
    targt2 = SHEHADA.Range("S7").Value & "*"
    targt3 = SHEHADA.Range("T7").Value & "*"
            '======================
c = 0
Application.ScreenUpdating = False
lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row   'اخر صف به بيانات

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  X = SHEHADA.Range("T1").Value
  Y = SHEHADA.Range("R1").Value
  Z = SHEHADA.Range("S1").Value
  U = IIf(X = 1, 7, Y)
  V = IIf(X = 1, lr, Z)

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'هذا السطر في حال كل الشهادات أو شهادات محددة
For i = U To V
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
  If DATA.Cells(i, 101) Like targt1 & "*" _
 And DATA.Cells(i, 104) Like targt2 & "*" _
 And DATA.Cells(i, 103) Like targt3 & "*" _
 And c = 0 Then
 
     Range("M3") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 1 Then
    
    Range("M19") = DATA.Cells(i, 2)
            c = c + 1
            '======================
            
 'ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    'And c = 2 Then
    
    'Range("M35") = DATA.Cells(i, 2)
           ' c = c + 1
            '======================

'ElseIf DATA.Cells(i, 101) Like targt1 & "*" _
    And DATA.Cells(i, 104) Like targt2 & "*" _
    And DATA.Cells(i, 103) Like targt3 & "*" _
    And c = 3 Then
    
  ' SHEHADA.Range("M51") = DATA.Cells(i, 2)
           ' c = c + 1
            '======================
    
            End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'If i = V And c = 4 Then SHEHADA.Range("a1:p63").PrintOut: Exit For
' If i = V And c = 3 Then SHEHADA.Range("a1:p47").PrintOut: Exit For
 If i = V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut: Exit For
 If i = V And c = 1 Then SHEHADA.Range("a1:p15").PrintOut: Exit For
 If i < V And (Range("M3") = "" Or Range("M19") = "") Then GoTo 1
 If i < V And c = 2 Then SHEHADA.Range("a1:p31").PrintOut
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     
     c = 0
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
   '  SHEHADA.Range("M35") = ""
   ' SHEHADA.Range("M51") = ""
    
1:
   Next i
     SHEHADA.Range("M3") = ""
     SHEHADA.Range("M19") = ""
    ' SHEHADA.Range("M35") = ""
   ' SHEHADA.Range("M51") = ""
   Application.ScreenUpdating = True
End Sub

كل شهادتين في صفحه واحدة

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

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر 
Sub SortData()

    Dim lr As Long

    lr = Range("E" & Rows.Count).End(xlUp).Row

    For Each Cell In ActiveSheet.Range("E7:E" & lr)

        Cell.Value = Application.WorksheetFunction.Trim(Cell.Value)

    Next

    Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo

End Sub

كود للفرز بمعيارين

ولكن به اضافه مفيده

وهي ازاله المسافات من بين الاسماء

مما تعطي فرزا دقيقا

للمحترم الغالي ياسر العربي

رابط هذا التعليق
شارك
  • 1 month later...

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

  I accept