اذهب الي المحتوي
أوفيسنا

[موضوع مميز]شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)[مثبت]


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

استخراج الشهادات بطريقه العلامه عبد الله باقشير

''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله
''استخراج شهادات الطلاب     الهدف من الكود


'رقم اول صف للشهادة
Const FirstRow As Integer = 7
'-------------------------------
'عدد صفوف الشهادة
Const CountRow As Integer = 11
'-------------------------------
'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة
Const CountColumn As Integer = 13
'-------------------------------
Const Range_Index As String = "A7"
'-------------------------------
Dim KH_Boolean As Boolean, KH_Test As Boolean
Sub الكل()
Call kh_Test_Fill(Sheet3.Range("D1"))
If KH_Test Then GoTo 1
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub الناجحين()
Call kh_Test_Fill(Sheet3.Range("G1"))
If KH_Test Then GoTo 1
Call kh_Nd("ناجح")
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub دور_ثاني()
Call kh_Test_Fill(Sheet3.Range("J1"))
If KH_Test Then GoTo 1
Call kh_Nd("دور ثاني")
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub kh_Test_Fill(MyCel As Range)
Dim R As Integer, RR As Long
KH_Boolean = True: kh_Delete: KH_Boolean = False
KH_Test = False
If Not IsNumeric(MyCel) _
Or (IsNumeric(MyCel) And MyCel.Value = 0) Then _
MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & MyCel, 524288 + 1048576 + 16, "بيانات غير متوفرة": KH_Test = True: GoTo 1

R = MyCel.Value
With Sheet3
    .Range(Range_Index).Value = 1
    If R = 1 Then GoTo 1
    RR = (R * CountRow)
    Call kh_AutoFill(.Rows(FirstRow).Resize(CountRow), .Rows(FirstRow).Resize(RR), .Range("B" & FirstRow).Resize(RR, CountColumn).Address)
End With
1
End Sub
Sub kh_AutoFill(SourceRange As Range, fillRange As Range, Kh_PrintArea As String)
SourceRange.AutoFill fillRange, xlFillDefault
Sheet3.PageSetup.PrintArea = Kh_PrintArea
End Sub
Sub kh_Nd(Nd As String)
Dim MyRng As Range
Dim R As Integer, RR As Long
Set MyRng = Range("data").Columns(46)
RR = FirstRow
With MyRng
    For R = 1 To .Rows.Count
        If .Cells(R, 1) = Nd Then
            Sheet3.Cells(RR, 1) = R
            RR = RR + CountRow
        End If
    Next
End With
End Sub
Sub kh_Delete()
Dim T As Long
Application.ScreenUpdating = False
With Sheet3
    .Range(Range_Index).ClearContents
    T = .UsedRange.Rows.Count
    .Rows(FirstRow + CountRow).Resize(T).Delete
End With
If KH_Boolean Then GoTo 1
Application.ScreenUpdating = True
MsgBox "تم مسح الشهادات", vbMsgBoxRight, "الحمد لله"
1 End Sub

 

استخراج شهادات بطريقه العلامه عبد الله باقشير.rar

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

وموجود ايضا بالملف السابق اردت ان اضع الاضواء عليه

Sub KH_Sort()
''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله
''فرز بيانات الطلاب بمعيار الفصل   الهدف من الكود

Dim MyShap As Shape
Dim T As Integer
Set MyShap = Sheet4.Shapes("Kh_Num")
If MyShap.ControlFormat.Value = 1 Then T = 2 Else T = 1
    Range("data").Sort Range("AU12"), T
End Sub

 

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

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

توزيع اللجان وارقام الجلوس بالمعادلات.rar

توزيع كشوف المناداه .. وارقام الجلوس للدور التاني 

للمحترم الاستاذ محمد علي عبد الكريم

 

توزيع لجان الدور التاني.rar

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

استخراج القيم الفريده

 

Const StudentData As String = "بيانات الطلبة"
Const TopStudents As String = "الاوائل"

Private Sub Worksheet_Activate()

Application.DisplayAlerts = False
Sheets(TopStudents).Range("S:S").ClearContents

Sheets(StudentData).Range("V5:V1000").AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheets(TopStudents).Range("S8"), unique:=True
Sheets(TopStudents).Range("S9").Value = "الكل"

With Sheets(TopStudents).Range("S8")
        .Interior.Pattern = xlSolid
        .Interior.Color = 65535
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .Font.Size = 16
End With

With Sheets(TopStudents).Range("S9:S100")
        .Interior.Pattern = xlSolid
        .Interior.ColorIndex = 0
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .Font.ColorIndex = 0
        .Font.Size = 16
End With

Macro1
Application.DisplayAlerts = True
End Sub

 

فلترة متقدمة.zip

كشوف المناداه وارقام الجلوس يصلح للثانوي العام

 

 

كشوف المناداه وارقام الجلوس للثانوي العام.rar

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

قوائم منسدله دون تكرار بالمعادلات

=INDEX(Feuil1!$A:$A;MIN(IF(COUNTIF(B$2:B2;List)=0;ROW(List))))&""

 

قوائم منسدلة دون تكرار ودون فراغات.rar

 

 

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

معادله مطاطيه لاستخراج القيم الفريده

=INDEX('بيانات الطلبة'!$V$7:$V$212;MATCH(0;COUNTIF($S$9:$S9;'بيانات الطلبة'!$V$7:$V$212);0))

 

قائمة مطاطة خاليه من ظهور علامات الخطأ.rar

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

  • 2 months later...

روابط لكنترولات مفيده
نسخة التعليم الإبتدائى
من الميديا فاير

نسخة التعليم الإعدادى
من الميديا فاير

نسخة التعليم الثانوى العام
من الميديافاير

نسخة التعليم الصناعى
من الميديا فير


نسخة التعليم التجارى
من الميديا فير


نسخة التعليم الفندقى
من الميديا فير


نسخة التعليم الإبتدائى للأزهر الشريف
من الميديا فير


البرنامج لا يفتح الا من خلال كلمة مرور (1) يمكن تغييرها كيفما تشاء
الانتقال من مستوى صلاحية الى اخر يتم من خلال كلمة مرور اخرى (1)
يمكن ايضا تغييرها فى أى وقت

فمثلاً
يمكن تفعيل قائمة (جلوس وسرى) وقائمة (مطبوعات) باتباع الاتى :
اعدادات - تغيير الصلاحية - اختيار رئيس الكنترول - وضع كلمة المرور:1 ثم الضغط على موافق

 

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

في 10/9/2014 at 21:02, قصي said:

تم بفضل الله ثم بفضل الاستاذ رجب جاوبش بارك الله فيه تنفيذ المطلوب

وهذا هو المرفق

ابجده فور الكتابه1.rar

هل يمكن تغير ولد - بنت الى     1-2   1 ولد      2   بنت    ما هو التغير فى الكود

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

  • 3 weeks later...

توزيع لجان الطلبه كل 4 لجان في صفحه من الروائع

http://up.top4top.net/downloadf-3402c7sr1-rar.html

 

Option Explicit
Option Base 1
Dim myc As Range
Dim myrang2 As Range
Sub PrepareCol()
Application.ScreenUpdating = False
' توزيع مبدئي
setmyrng
aly_Clear
'Sheets("اللجان").Cells.Clear
'رقم آخر صف فى جدول المدى من إلى
Dim LR_Info  As Long
' آخر صف فى عمود البيانات شيت 1
Dim LastRow As Long
' آخر صف فى شيت 2
Dim LastRow2 As Long
'الخلية إلى فى الجدول و الخلية من
Dim ToRow As Long, FromRow As Long
'  مصفوفة من 3 عناصر لتخزين رقم العمود الجديد
Dim LR(0 To 3) As Long
' جدول المدى
Dim TableInfo()
Dim i As Long, K As Integer
Dim MyRg As Range
Dim mycl As Range
Dim myallrange As Range
Dim y As Long
Dim x As Integer
Dim z As Long
Dim m As Long
Dim s As Integer
Dim T As Integer
Dim o As Long, ss As Integer, g As Long, h As Long, u As Long, f_end As Long
s = Application.CountA(ورقة2.Range("J9:J500"))
ss = Application.RoundUp(s / 4, 0)
Dim myrase As Range, mydall As Range, myarwa As Range, myaly As Range
'Sheets("اللجان").Select
'Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
 
    Sheets("data").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    LR_Info = Cells(Rows.Count, Range("إلى").Column).End(xlUp).Row
    LastRow2 = Sheets("اللجان").Range("B" & Rows.Count).End(xlUp).Row + 1
    'توزيع أرقام الجلوس حسب بداية الترقيم
    Set myallrange = Sheets(1).Range("b2:b" & LastRow)
   ' For Each mycl In myallrange
         ' mycl.Offset(, 1).Value = Range("e12") + y
        'y = y + 1
        'Next mycl
    
    Range(Range("إلى").Offset(1), Cells(LR_Info, (Range("إلى").Column) + 1)).Select
    ' حدود الجدول لاحظ تحديد مدى الجدول باستخدام رينج و سيلس معا
    TableInfo = Range(Range("من").Offset(1), Cells(LR_Info, (Range("من").Column) + 1))
    K = 0
    x = 7
    ' UBound لمعرفة طول المصفوفة أو الجدول
    On Error Resume Next
    
     For m = 1 To ss
    For i = 1 To UBound(TableInfo())
        ToRow = TableInfo(i, 2)
        FromRow = TableInfo(i, 1)
        
          Set MyRg = Range("e6:e8")
        MyRg.Copy Destination:=Sheets("اللجان").Cells(LastRow2, K * 4 + 1)
        Sheets("اللجان").Cells(LastRow2 + 3, K * 4 + 1).Value = "لجنة رقم :" & i
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Value = " من " & FromRow + Sheets("data").Range("e12") - 1
        'Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(, 1) = FromRow + Sheets("data").Range("e12").Value - 1
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(, 2) = "العدد "
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(1, 2) = ToRow - FromRow + 1
        Sheets("اللجان").Cells(LastRow2 + 5, K * 4 + 1).Value = " إلى " & ToRow + Sheets("data").Range("e12") - 1
        
        'Sheets("اللجان").Cells(LastRow2 + 5, K * 4 + 1).Offset(, 1) = ToRow + Sheets(1).Range("e11").Value - 1
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 1).Value = " م "
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 2).Value = " اسم الطالب "
        'Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 3).Value = "رقم الجلوس"
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 1).Offset(, 2) = "رقم الجلوس"
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 4).Value = "الديانة"
          Set MyRg = Range(Cells(FromRow + 1, "B"), Cells(ToRow + 1, "d"))
        MyRg.Copy Destination:=Sheets("اللجان").Cells(LastRow2 + x, K * 4 + 2)
        Set myrase = Range("rase")
        Set mydall = Range("dell")
        Set myarwa = Range("anas")
        myrase.Copy
        Sheets("اللجان").Cells(LastRow2, K * 4 + 1).PasteSpecial xlPasteFormats
        
        'التسلسل
        
        For z = 1 To ToRow - FromRow + 1
            Sheets("اللجان").Cells(LastRow2 + z + 6, K * 4 + 1).Value = z
            
            myarwa.Copy
         Sheets("اللجان").Cells(LastRow2 + z + 6, K * 4 + 1).PasteSpecial xlPasteFormats
            
            Next z
            
            Set MyRg = Range("e10")
        Sheets("اللجان").Cells(LastRow2 + x - 1 + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس الكنترول " & "/" & MyRg
        Sheets("اللجان").Cells(LastRow2 + x + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس لجنة الامتحان  " & "/" & MyRg.Offset(1, 0)
        
        'Sheets("اللجان").Cells(LastRow2 + x + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس لجنة الامتحان  " & "/" & MyRg.Offset(1, 0)
        
        mydall.Copy
        Sheets("اللجان").Cells(LastRow2 + x - 1 + (ToRow - FromRow + 2), K * 4 + 1).PasteSpecial xlPasteFormats
         
              
              K = K + 1
        K = K Mod 4
        LR(K) = LastRow2 + x + ToRow - FromRow + 3
        If (K = 0) Then LastRow2 = Application.Max(LR(0), LR(1), LR(2), LR(3))
        Sheets("اللجان").Select
        ActiveWindow.View = xlPageBreakPreview
        'g = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1
        'h = Sheet1.Cells(Rows.Count, 6).End(xlUp).Row + 1
        If (K = 0) Then
        'If LastRow2 = 2 Then GoTo 1
        'If h > g Then
        Set ActiveSheet.HPageBreaks(m).Location = Range("A" & LastRow2)
        'Else
        'Set ActiveSheet.HPageBreaks(m).Location = Range("A" & g)
        m = m + 1
        End If
      
1      Sheets("data").Select
    Next i
   Next m
    With Sheets("اللجان")
    o = .Cells(Rows.Count, 2).End(xlUp).Row
    g = .Cells(Rows.Count, 6).End(xlUp).Row
    u = .Cells(Rows.Count, 10).End(xlUp).Row
    h = .Cells(Rows.Count, 14).End(xlUp).Row
        .Range("a:p").ReadingOrder = xlRTL
        .Range("a:p").Font.Bold = True
        .Range("a:p").Font.Size = 13
        .Range("a:p").Font.Name = "Arial"
       f_end = Application.Max(o, g, u, h)
       .PageSetup.PrintArea = .Range("A2:p" & f_end).Address
        'If o > g Then
        '.PageSetup.PrintArea = .Range("A2:p" & o).Address
        'Else
        '.PageSetup.PrintArea = .Range("A2:p" & g).Address
        'End If
    End With
    Sheets("اللجان").Select
    ActiveWindow.View = xlNormalView
    Range("A1").Activate
    Set MyRg = Nothing
    Set myallrange = Nothing
   Sheets("data").Select
   Range("A1").Activate
End Sub
Sub dsds()
Dim LastRow2 As Long
LastRow2 = Sheets("اللجان").Range("B" & Rows.Count).End(xlUp).Row + 1
'Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
Sheets("اللجان").Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
End Sub

Sub aly_Clear()
    Dim y As Integer
    Application.ScreenUpdating = False
    With Sheet1
            
        y = .UsedRange.Rows.Count + 100
        .Range("A2:p" & y).Clear
        .ResetAllPageBreaks
        .PageSetup.Zoom = 92
        .PageSetup.PrintArea = .Range("A2:p10000").Address
        Range("A1").Activate
    End With
End Sub
Sub jhjjhjh()
'On Error Resume Next
Dim o As Integer, b As Integer, d As Range, dd As Integer, g As Integer, h As Integer
 With Sheets("اللجان")
    o = .Cells(Rows.Count, 2).End(xlUp).Row
    g = .Cells(Rows.Count, 6).End(xlUp).Row
        .Range("a:k").ReadingOrder = xlRTL
        .Range("a:k").Font.Bold = True
        If o > g Then
        .PageSetup.PrintArea = .Range("A2:H" & o).Address
        Else
        .PageSetup.PrintArea = .Range("A2:H" & g).Address
        End If
    End With

End Sub
Sub muuyy()
'On Error Resume Next
Dim E As Integer, b As Integer, d As Integer, dd As Integer, gg As Integer, hh As Integer
'g = Application.CountA(ورقة2.Range("J9:J500"))
b = 9
E = 2
d = Application.RoundUp(b / 2, 0)


End Sub
Sub ads222s()
With ورقة1.Range("a1:p300")
           .ShrinkToFit = True
           .ReadingOrder = xlRTL   ' اتجاه النص
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
         End With
With ورقة1.Range("a1:p300").Font
        .Name = "Arial"
        .FontStyle = "غامق"
        .Size = 13
End With

End Sub

 

Sub setmyrng()
Sheets("data").Range("h9:i500").ClearContents
Sheets("data").Range("h9") = 1
Range("i9") = Range("j9")
Range("h10") = Range("i9") + 1
Dim myc As Range
Dim myrang2 As Range

    Set myrange2 = Range("j10:j500")
    For Each myc In myrange2
    
    If myc <> "" Then
    myc.Offset(0, -1) = (myc.Value + myc.Offset(0, -2).Value) - 1
    If myc.Offset(1, 0) <> "" Then
    myc.Offset(1, -2) = myc.Offset(0, -1) + 1
    'myc.Offset(1, -2) = myc.Offset(0, -1) + 1
    End If
    End If
    Next myc
    
End Sub

 

كود الدوائر الحمرا ولااسهل

http://up.top4top.net/downloadf-340w1meo1-rar.html

'هذا الكود للمبدعه ساجده العزاوي
'الهدف من الكود هو وضع دوائر حمراء حول الدرجات الضعيفه بمعيارك
'

Dim c As Range
 Dim o As Shape
 Dim N As Integer
 

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("c1:i1")) Is Nothing Then
GoTo 1
Else
1:
N = Target.Column
Select Case N

Case 3
 A = [C1].Value
 
 Case 4
  A = [D1].Value
 
 Case 5
  A = [E1].Value
 
 Case 6
  A = [F1].Value
  
 Case 7
  A = [G1].Value
 
 Case 8
  A = [H1].Value

  Case 9
  A = [I1].Value
 
End Select
 
       For Each c In Range(Cells(2, N), Cells(8, N))
       If c.Value < A And A <> "" Then
         Set o = Sheets("younes").Shapes.AddShape(msoShapeOval, _
               c.Left, c.Top, c.Width, c.Height)
           o.Fill.Visible = msoFalse
           o.Line.ForeColor.SchemeColor = 10
           o.Line.Weight = 1.25
           o.Name = "S" & c.Address
        Else
   Dim shp As Shape
   For Each shp In ActiveSheet.Shapes
       If shp.Name Like "S" & c.Address Then shp.Delete
    Next
    End If
   Next
   
End If


  End Sub
 

 

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

تلوين خلايا بشرط

http://up.top4top.net/downloadf-3401oiyo1-rar.html

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

ملف لتوزيع اللجان

 

طباعـــــــــــــه صفحات.rar

استدعاء بيانات بطريقه سريعه جدا


'''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
Sub DOR_tan()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو فلترة البيانات
''شرح الكود
''
    Dim myArray, lr, X, targt, targt1, targt2, targtN
    Dim SERCH As Worksheet, DATA As Worksheet
    '____________________________________________
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت  المصدر
    Set SERCH = Worksheets("كشف الدور الثاني")    'اسم الشيت الهدف
    '____________________________________________
    Range("A8:R1000").Clear
    'النطاقات متغيره
    Range("B7:R7").AutoFill Destination:=Range("B7:R" & Range("A4").Value + 6), Type:=xlFillDefault
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2  'اخر صف به بيانات
    'رقم عمود البدايه اللي بعد المسلسل
  '  متغير
    SERCH.Range("C7:N" & SERCH.Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = "له* دور ثان في"    'معيار البحث
    
     'نطاق قاعدةالبيانات المصدر الذي سيتم البحث فيه
    myArray = DATA.Range("A7:EF" & lr)
    '____________________________________________
    'عدد الاعمده في الجدول في صفحه الهدف
    ReDim y(1 To lr, 1 To 13)
    For X = 1 To lr - 6
        If targt = "" Then Exit Sub
        
        'رقم عمود معيار البحث
        If myArray(X, 101) Like targt & "*" Then
            rw = rw + 1
            'For ww = 1 To 102
              '  Y(rw, ww) = myArray(X, ww)
          '  Next ww
    'العمود التاني بعد المسلسل
          y(rw, 1) = myArray(X, 2)
          
              'العمود الثالث بعد المسلسل
          y(rw, 2) = myArray(X, 3)
          
              'العمود الرابع بعد المسلسل
          y(rw, 3) = myArray(X, 13)
          
              'العمود الخامس بعد المسلسل
          y(rw, 4) = myArray(X, 22)
          
              'العمود السادس بعد المسلسل وهكذا
          y(rw, 5) = myArray(X, 31)
          
          y(rw, 6) = myArray(X, 40)
          y(rw, 7) = myArray(X, 51)
          y(rw, 8) = myArray(X, 52)
          y(rw, 9) = myArray(X, 82)
          y(rw, 10) = myArray(X, 101)
          y(rw, 11) = myArray(X, 102)
        '  Y(rw, 12) = myArray(X, 110)
         ' Y(rw, 13) = myArray(X, 111)
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 3).End(xlUp)(2, 1).Resize(rw, 13).Value = y()
End Sub

 

استدعاء بيانات بطريقه سريعه.rar

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

كشوف لجان متميزه

Sub PrintFrom8_To_()
MsgBox "للحصول على طباعة كاملة يجب عدم ملامسة الماوس أو لوحة المفاتيح أثناء الطباعة"
Dim I As Integer
For I = Range("t7") To Range("u7") Step 2
If I <= Range("u7") Then
Range("e5") = I
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
End If
Next I
Range("e5").Select
End Sub

 

كشوف لجان متميزه.rar

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

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

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

Important Information