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

محمدي عبد السميع

04 عضو فضي
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    630

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    2

 نوع المحتوي 

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

    حذف جميع المديولات في حالة كسر كلمة المرور

    في منتدى الاكسيل Excel

    قام بنشر

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

    بتقول انت تعبت في عمل الاكواد 

    ومش عايز واحد ياخد اي كود

    طيب ممكن تكتب كود واحد من تصميمك هنا 

    ولا تم اخد الاكواد من المنتديات وتطويعها لك وخايف حد يشوف انك اخدتها منهم ... مجرد سؤال

    عايزين العلم ينتشر

    الله يرحم والديك ووالدينا

     

    • Like 4

    برنامج شئون العاملين للاستاذ القدير عبد الباري البنا

    في منتدى الاكسيل Excel

    قام بنشر 

    

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Const GWL_STYLE = -16
Const WS_CAPTION = &HC00000
Const WS_SYSMENU = &H80000
'======================================================
'======================================================
'     تنسيق التاريخ
Private Const DtF As String = "yyyy/mm/dd"
'======================================================
'     عُرض تاكست الادخال
Private Const iWgt1   As Single = 240
'======================================================
Private Const Frmtop  As Single = 3
Private Const Frmlft  As Single = 3
Private Const iHgt    As Single = 35
Private Const iTop    As Single = iHgt + 2
Private Const mBox    As Long = vbMsgBoxRight + vbMsgBoxRtlReading
'======================================================
Private Ar()          As Integer
Private MyRngSeri     As Range
Private MyRngdate     As Range
Private ContRow       As Long
Private iRow          As Long
Private LastColumn    As Integer
Private tSr           As Boolean
Private MyList        As String
Private tAc           As Boolean
Private iColor1       As Variant
Private iColor2       As Variant


Private Sub BoxFind_Click()
Dim tm As Integer
Me.ListFind.Clear
tm = Me.BoxFind.Tag
Me.Controls("Labeldt" & tm).ForeColor = vbBlack
tm = Me.BoxFind.ListIndex + 1
Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor
Me.BoxFind.Tag = tm
End Sub
Private Sub ButtonClear_Click()
kh_ClearRecord
End Sub
Private Sub ButtonEnd_Click()
Me.ScrollBar1.Value = ContRow
End Sub
Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False)
Dim tm As Integer
''''''''''''''''''''''''''''''''
For tm = 2 To LastColumn
    If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then
        Me.Controls("Textdt" & tm) = ""
    End If
Next
End Sub
Private Sub kh_AddNewRecord()
Dim C As Integer
''''''''''''''''''
Me.Frame1.ScrollTop = 0
kh_ClearRecord True
''''''''''''''''''
Me.LabelSerial = ContRow + 1
Me.LabelSerial2 = ContRow + 1 & "  -  " & ContRow + 1
kh_Enabled False
''''''''''''''''''
With Me.Controls("Textdt1")
    If .Enabled Then
        .SetFocus
        .Text = "يجب الادخال في هذه الخلية افتراضياً"
        .SelStart = 0
        .SelLength = .TextLength
    Else
        .Text = "........"
    End If
End With
End Sub

Private Sub ButtonGo_Click()
With MyRngdate
    .Worksheet.Activate
    .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select
End With
Unload Me
End Sub

Private Sub ButtonNew_Click()
kh_AddNewRecord
End Sub

Private Sub ButtonNewCancel_Click()
ScrollBar1_Change
End Sub

Private Sub ButtonNewSave_Click()
If kh_TestBlank() Then Exit Sub
Dim cRow As Long: cRow = ContRow + 1
Me.ScrollBar1.Max = cRow
kh_SaveDate cRow, True
Me.ScrollBar1.Value = cRow
Call MsgBox("  تم حفظ السجل الجديد بنجاح  ", mBox, "الحمدلله")

End Sub

Private Sub ButtonPrint_Click()
If Me.Frame1.ScrollHeight > Me.Frame1.Height Then
    Print1
Else
    If MsgBox(" هل تريد طباعة السجل على الفورم  ؟  ", vbYesNo + mBox, "طباعة على الفورم ") = vbYes Then
        Print2
    Else
        Print1
    End If
End If
End Sub

Private Sub Print1()
Dim ctl As Control
Dim i As Integer, t As Boolean
Me.Hide
'------------------------
With Workbooks.Add(xlWBATWorksheet)
    .Activate
    For i = 1 To LastColumn
        Cells(i, "B").Value = CStr(Me.Controls("Labeldt" & i))
        Cells(i, "C").Value = CStr(Me.Controls("Textdt" & i))
    Next
    With Range("B1").Resize(LastColumn, 2)
        .ColumnWidth = IIf(t, 28, 37)
        .Borders.LineStyle = 2
        .WrapText = True
        .VerticalAlignment = xlTop
    End With
    Range("A1").ColumnWidth = IIf(t, 17, 0)
    If t Then AddPrintPicture
    Range("A1").Resize(LastColumn, 3).PrintPreview
    .Close False
End With
'------------------------
Me.Show
End Sub
Private Sub Print2()
Print_Visible False
''''''''''''''''''''''''''
If MsgBox(" هل تريد طباعة الفورم حسب هذه المعاينة ؟  ", vbYesNo + mBox, "معاينة قبل الطباعة") = vbYes Then
    On Error Resume Next
    Me.PrintForm
    On Error GoTo 0
End If
''''''''''''''''''''''''''
Print_Visible True
kh_Enabled True
End Sub

Private Sub Print_Visible(v As Boolean)
Dim ctl As Control
''''''''''''''''''''''''''
If v Then
    Me.BackColor = iColor1
    With Me.Frame1
        .BackColor = iColor2
        .SpecialEffect = 3
    End With
Else
    Me.BackColor = vbWhite
    With Me.Frame1
        .BackColor = vbWhite
        .SpecialEffect = 0
    End With
End If
End Sub

Private Sub ButtonSaveDate_Click()
If kh_TestBlank() Then Exit Sub
kh_SaveDate iRow
ScrollBar1_Change
Call MsgBox("  تم حفظ التغييرات  بنجاح  ", mBox, "الحمدلله")

End Sub

Private Function kh_TestBlank() As Boolean
If Len(Trim(Me.Controls("Textdt1"))) = 0 Then
    kh_TestBlank = True
    Me.Controls("Textdt1").SetFocus
    Call MsgBox("العمود : " & Me.Controls("Labeldt1") & vbCr & vbCr & "يجب الادخال في هذه الخلية افتراضياً", mBox + vbCritical, "استخدام خاطىء")
End If
End Function
Private Sub kh_AutoFill()
Dim CelFill As Range, CFil As Range
Dim R As Integer
''''''''''''''''''''''''''
If tSr Then
    Set CelFill = Union(MyRngSeri, MyRngdate)
Else
    Set CelFill = MyRngdate
End If
''''''''''''''''''''''''''
For R = 1 To CelFill.Areas.Count
    Set CFil = CelFill.Areas(R).Rows(ContRow + 1)
    With CFil
        .AutoFill .Resize(2), xlFillDefault
    End With
Next
Set CelFill = Nothing
Set CFil = Nothing
End Sub

Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False)
Dim MyVelue, Msg
Dim C As Integer, cc As Integer
''''''''''''''''''''''''''
'On Error GoTo 1
''''''''''''''''''''''''''
Application.Calculation = xlCalculationManual
''''''''''''''''''''''''''
If nR > 1 And tFil Then kh_AutoFill
If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR
'''''''''''''''''''''''''''
For cc = 1 To LastColumn
    C = Ar(cc)
    If Me.Controls("Textdt" & cc).Enabled = True Then
        With MyRngdate
            MyVelue = Me.Controls("Textdt" & cc).Text
            If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then
                MyVelue = Format(MyVelue, DtF)
            Else
                If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then
                    Msg = MsgBox("الخلية في العمود : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _
                    & "منسقة كتاريخ والادخال الجديد رقم" & vbCr & vbCr _
                    & "هل تريد مسح تنسيقات الارقام السابقة ؟؟", mBox + vbYesNo, "تأكيد مسح تنسيقات التاريخ السابقة ؟؟  ")
                    '''''''''''''''''''''''''
                    If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = ""
                End If
            End If
            .Cells(nR + 1, C).Value = MyVelue
        End With
    End If
Next

''''''''''''''''''''''''''
1:
Application.Calculation = xlCalculationAutomatic
''''''''''''''''''''''''''

End Sub

Private Sub ButtonExit_Click()
Unload Me
End Sub

Private Sub ButtonDelete_Click()
If MsgBox("  هل تريد حذف السجل رقم : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "تاكيد الحذف ") = vbNo Then Exit Sub

If Me.ListFind.ListCount Then Me.ListFind.Clear
MyRngdate.Rows(iRow + 1).EntireRow.Delete
If Not tSr Then GoTo 1
If iRow = ContRow Then GoTo 1
With MyRngSeri
    .Cells(iRow + 1, 1).Value = iRow
    Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries
End With
1:
Me.ScrollBar1.Max = ContRow - 1
ScrollBar1_Change
Call MsgBox("  تم حذف السجل  بنجاح  ", mBox, "الحمدلله")

End Sub

Private Sub ButtonTop_Click()
If ContRow Then Me.ScrollBar1.Value = 1
End Sub

Private Sub CheckFind_Click()
Me.ListFind.Clear
Me.LblFindCount = 0
End Sub

Private Sub CheckFindDate_Click()
If Me.CheckFindDate.Value = True Then
    kh_SetDate Me.TextFind
    ''''''''''''''''''''''''''''
End If
End Sub


Private Sub CommandButton1_Click()
 ActiveWorkbook.save
 Call MsgBox("  تم حفظ الكل بنجاح  ", mBox, "الحمدلله")
End Sub

Private Sub CommandButton2_Click()
    ChaingeLanguage "Arabic"
    TextFind.SetFocus
End Sub

Private Sub CommandButton3_Click()
   ChaingeLanguage "English"
   TextFind.SetFocus
End Sub

Private Sub CommandButton4_Click()
Me.TextFind.Value = ""
End Sub

Private Sub CommandButton6_Click()
a = Application.Height - 10: b = Application.Width

    With Me
    .Width = .Width * 1.1
    .Height = .Height * 1.1
    .zoom = .zoom * 1.1
    .Top = (a - .Height) / 2
    .Left = (b - .Width) / 2
    End With

End Sub

Private Sub CommandButton7_Click()
a = Application.Height - 10: b = Application.Width

    With Me
    .Width = .Width / 1.1
    .Height = .Height / 1.1
    .zoom = .zoom / 1.1
    .Top = (a - .Height) / 2
    .Left = (b - .Width) / 2
    End With





End Sub

Private Sub LabelH2_Click()
    Call MsgBox(" سيتم تحويل اي قيمة تضعها في مربع النص للبحث " _
        & vbCr & vbCr & "الى تاريخ بالتنسيق الافتراضي للفورم ,,,,,,," _
        & vbCr & String$(40, "=") _
        & vbCr & vbCr & "مع امكانية ادخال رقم صحيح بين 1 الى 31 ليفهم على انه " _
        & vbCr & vbCr & "تاريخ اليوم للشهر الحالي والسنة الحالية " _
        , mBox + vbQuestion + vbApplicationModal, "تعليمات")
    '''''''''''''''''''''''''''

End Sub


Private Sub ListFind_Click()
Dim RR As Long
RR = Me.ListFind.Column(1)
Me.ScrollBar1.Value = RR
End Sub

Private Sub ScrollBar1_Change()
Dim MyVelue
Dim C As Integer, cc As Integer
Me.Frame1.ScrollTop = 0
With Me.ScrollBar1
    If ContRow = 0 Then .Min = 1
    iRow = .Value: ContRow = .Max
End With
'''''''''''''''''
For cc = 1 To LastColumn
    C = Ar(cc)
    With MyRngdate
        If IsDate(.Cells(iRow + 1, C)) Then
            MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF)
            Else: MyVelue = .Cells(iRow + 1, C).Value2
        End If
    End With
    On Error Resume Next
    Me.Controls("Textdt" & cc).Text = ""
    Me.Controls("Textdt" & cc).Text = MyVelue
    On Error GoTo 0
Next
'------------------------------
Me.LabelSerial.Caption = iRow
Me.LabelSerial2.Caption = iRow & "  -  " & ContRow
kh_Enabled True
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub TextFind_Change()
With Me.ListFind
    If .ListCount Then .Clear
End With
Me.LblFindCount = 0
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False)
End Sub

Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Me.CheckFindDate.Value = False Then Exit Sub
kh_SetDate Me.TextFind
End Sub

'  هذا الكود يرغمك بادخال تاريخ
Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control)
Dim dtest, dt
dtest = dCntrl
If Not IsDate(dtest) Then
    If IsNumeric(dtest) Then
        On Error Resume Next
        dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF)
        If Err Then dt = Format(Date, DtF)
        On Error GoTo 0
    Else
        dt = Format(Date, DtF)
    End If
    Else: dt = Format(CDate(dtest), DtF)
End If
dCntrl = dt
End Sub


Private Sub TextSerial_Change()
Dim v
v = Me.TextSerial.Text
If Len(v) = 0 Then Exit Sub
If Not IsNumeric(v) Then GoTo 1
If v = 0 Or v > ContRow Then GoTo 1
Exit Sub
'=======================
1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1)
End Sub

Private Sub TextSerial_AfterUpdate()
If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = ""
End Sub

Private Sub kh_Enabled(ByVal Ebl As Boolean)
Me.ButtonNewSave.Visible = Not Ebl
Me.ButtonNewCancel.Visible = Not Ebl
Me.ButtonNew.Visible = Ebl
Me.ButtonSaveDate.Visible = Ebl
''''''''''''''''''''''''''''''''''''''''''''
Me.ButtonPrint.Enabled = Ebl
Me.ButtonSaveDate.Enabled = Ebl
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False)
''''''''''''''''''''''''''''''''
Me.ButtonEnd.Enabled = CBool(iRow <> ContRow)
Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1)
Me.ButtonNewCancel.Enabled = IIf(iRow, True, False)
Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl)
End Sub

Private Sub ButtonSerach_Click()
Dim tb1 As Boolean, ib As Boolean
Dim R As Long, RR As Long
Dim C As Integer
Dim MyFind, MySrch, MyVelue
''''''''''''''''''''''
Me.ListFind.Clear
If Len(Trim(Me.TextFind)) = 0 Then Exit Sub
'''''''''''''''''''''
C = Me.BoxFind.ListIndex + 1
tb1 = CBool(Me.CheckFindDate.Value = True)
If tb1 Then
    If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind
    MyFind = CDbl(CDate(Me.TextFind))
    
Else
    MyFind = Me.TextFind.Value
End If
'''''''''''''''''''''''
With MyRngdate.Cells(2, Ar(C))
    For R = 1 To ContRow
        If Len(Trim(.Cells(R, 1))) Then
            If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value
            ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare))
            If ib Then
                MyVelue = .Cells(R, 1).Value
                If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF)
                Me.ListFind.AddItem MyVelue
                Me.ListFind.List(RR, 1) = R
                RR = RR + 1
            End If
        End If
    Next
End With

Me.LblFindCount = Me.ListFind.ListCount
If RR = 0 Then MsgBox " لا توجد نتائج لبحثك هذا  ", mBox, "تنبيه"

'''''''''''''''''''''''''
End Sub

Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "")
tSr = TypeName(Evaluate(aSr)) = "Range"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook
    If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr)
    Set MyRngdate = .Worksheets(MySht).Range(MyAddrs)
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With MyRngdate
    ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row
    LastColumn = .Cells.Count
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Col As Range
Dim ii As Integer
ReDim Ar(1 To LastColumn)
For Each Col In MyRngdate.Cells
    ii = ii + 1
    Ar(ii) = Col.Column - MyRngdate.Column + 1
Next
'''''''''''''''''''''''''''
End Sub

Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean
If Not Rng.Comment Is Nothing Then
    MyList = Trim(Replace(Rng.Comment.Text, Chr(10), ""))
    MyList = Replace(MyList, " ", "")
    If TypeName(Evaluate(MyList)) = "Range" Then
        kh_TestType = True
    End If
End If
End Function


Private Sub UserForm_Activate()
Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double
Dim MyBox As Control, MyLabl As Control
Dim t As Integer
Dim tTp As Boolean
Dim MyType As String
'''''''''''''''''''''
If tAc Then Exit Sub
'''''''''''''''''''''
Me.Caption = MyRngdate.Worksheet.Name
MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2)
With Frame1
    If MyScrollHeight > .Height Then
        .ScrollBars = 2
        .ScrollHeight = MyScrollHeight
    End If
End With
MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For t = 1 To LastColumn
    tTp = kh_TestType(MyRngdate.Cells(1, Ar(t)))
    MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1")
    Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True)
    With MyBox
        .Move Frmlft, MyTop, iWgt1, iHgt
        .TextAlign = 3
        If tTp Then
            .BackColor = 16763955
            .ControlTipText = "إختر من القائمة..تحياتى عبدالبارى البنا"
            On Error Resume Next
            .List = Range(MyList).Value
            If Err Then .AddItem Range(MyList).Cells(1, 1).Value
            On Error GoTo 0
        End If
        If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then
            .BackStyle = 0
            .TextAlign = 2
            .SpecialEffect = 3
            .Enabled = False
        End If
    End With
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True)
    With MyLabl
        .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt
        .SpecialEffect = 3
        .TextAlign = 2
        .Caption = MyRngdate.Cells(1, Ar(t))
    End With
    '''''''''''''''''''''''''''''''''''
    Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2
    MyTop = MyTop + iTop
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.BoxFind
    .Style = 2
    .Tag = 1
    .ListIndex = 0
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.ScrollBar1
    .Max = ContRow
    If ContRow Then
        .Min = 1
        '.Value = ContRow
    Else
        kh_AddNewRecord
    End If
End With
tAc = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Me.TextBox1.Value = ورقة13.Range("f18").Value
 CheckFind.Value = True
End Sub

Private Sub UserForm_Initialize()
Dim LaCouleur As String
Dim Te
LaCouleur = xlThemeColorLight1
Te = ("&&..الله اكبر..&&   اهلا بكم فى برنامج شئون العاملين بالتربية والتعليم ........................إعداد وتصميم .. عبدالبارى البنا  &&..ولله الحمد..&&")
Me.WebBrowser1.Navigate _
"about:<html><body scroll='no'><font color= " & LaCouleur & " size='4' face='NEW'>" & _
"<marquee direction=right>" & Te & "</marquee></font></body></html>"
'Dim Zo%
'Dim ZH#, ZW#, AL#, AT#, AH#, AW#
'Dim FH!, FW!
'''''''''''''''''''''''
'AH = Application.Height: AW = Application.Width
'AL = Application.Left: AT = Application.Top
'FH = Height: FW = Width
'ZH = AH - FH: ZW = AW - FW: Zo = zoom
'If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW)
'''''''''''''''''''''''
'Move AL, AT, AW, AH
'If Zo <> 100 Then zoom = Zo
'===========================================
iColor1 = Me.BackColor
iColor2 = Me.Frame1.BackColor
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Me.TextBox1.Value = ورقة13.Range("f18").Value
End Sub

Private Sub UserForm_Terminate()
Set MyRngdate = Nothing
Erase Ar
End Sub


Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)

End Sub

    كود اخر ولا في الاحلام

    • Like 1

    برنامج شئون العاملين للاستاذ القدير عبد الباري البنا

    في منتدى الاكسيل Excel

    قام بنشر 

    
Option Explicit

'======================================================
'  اول صف للتقرير
Private Const iRow As Integer = 8
'------------------------------------------------------
'  اسم ورقة التقارير
Private Const Sh_Report As String = "التقرير"
'------------------------------------------------------
'  اسم ورقة البيانات
Private Const Sh_MyDate As String = "data"
'------------------------------------------------------
'  تعيين نطاق الخلايا في ورقة البيانات
'        ويشمل رؤوس الاعمدة
Private Const MyRng_MyDate As String = "A2:z1000"
'======================================================

Private MyRng As Range
Private Num As Integer
Private Const Mycount As Integer = 10

Private Sub CommandButton1_Click()

Dim R As Integer
Application.ScreenUpdating = False
For R = 1 To Num
    If Me.Controls("CheckBox" & R).Value = True Then
        Kh_Start R
    End If
Next
Kh_PageSetup
Application.GoTo Range("A1"), True
Application.ScreenUpdating = True
Unload Me
End Sub
Private Sub Kh_Start(iColumn As Integer)
Dim RCount As Long, C As Integer
C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1
With MyRng
    RCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(1, iColumn).Resize(RCount, 1).Copy
    '  لصق عرض الاعمدة
    Cells(iRow, C).PasteSpecial xlPasteColumnWidths
    '  لصق الفورمات
    Cells(iRow, C).PasteSpecial xlPasteFormats
    '  لصق القيم
    Cells(iRow, C).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End With
End Sub
Private Sub UserForm_Initialize()
    Dim MyTop As Integer, i As Integer
    Dim MyCBox As Control
    '========================
    kh_MyRngSet
    '========================
    MyTop = 0
    For i = 1 To Num
        Set MyCBox = Frame1.Controls.Add("Forms.CheckBox.1")
        With MyCBox
            .Move 12, MyTop, , , True
            .Alignment = 0
            .Font.Bold = True
            .Caption = MyRng.Cells(1, i).Value
            .Value = True
            .TextAlign = fmTextAlignRight
        End With
        MyTop = MyTop + 24
    Next
    '========================
    With Me
        If Num <= Mycount Then
            .Height = 60 + (24 * Num)
            .Frame1.Height = (24 * Num)
        Else
            .Height = 60 + (24 * Mycount)
            .Frame1.Height = (24 * Mycount)
            .Frame1.ScrollBars = 2
            .Frame1.ScrollHeight = (Num) * 24
        End If
    End With
    '========================
End Sub
Private Sub kh_MyRngSet()
With Sheets(Sh_Report)
    .Select
    .Range(Cells(iRow, 2), Cells(.Rows.Count, .Columns.Count)).Clear
    .PageSetup.PrintArea = ""
End With
With Sheets(Sh_MyDate)
    Set MyRng = .Range(MyRng_MyDate)
End With
Num = MyRng.Columns.Count
End Sub
Private Sub Kh_PageSetup()
Dim Lastrow As Long
Dim LastColumn As Integer
With Sheets(Sh_Report)
    Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    LastColumn = .Cells(iRow, Columns.Count).End(xlToLeft).Column
    With .PageSetup
        .PrintArea = Range("B2", Cells(Lastrow, LastColumn)).Address
        .zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
End With
End Sub
Private Sub UserForm_Terminate()
Set MyRng = Nothing
End Sub

    البرنامج كنز يحتوي على مجموعه من الاكواد ولا أروع

    هذا الكود للعلامه عبد الله باقشير

    • Like 1

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

    في منتدى الاكسيل Excel

    قام بنشر

    اضافه للنابغه الأستاذ حسونه حسن

    يبارك له ربنا

    اربط هذا الكود بزر الاستدعاء 

    Sub Test(Arr1 As Variant)
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
    Dim Ws As Worksheet, Sh As Worksheet
    Dim Arr As Variant, Temp As Variant    ', Arr1 As Variant
    Dim LR As Long, i As Long, j As Long, p As Long
    '-----------------------------------------
    Set Ws = Sheets("المواد منفصله")
    Set Sh = Sheets("data1")
    LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
    Ws.Range("C5:H34").ClearContents
    Arr = Sh.Range("A7:AB" & LR).Value
    ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
    For i = 1 To UBound(Arr)
        '------------------------------------------
        If Arr(i, 4) = Ws.Range("D3").Value Then
            '------------------------------------------
            p = p + 1
            For j = 0 To UBound(Arr1)
                Temp(p, j) = Arr(i, Arr1(j))

            Next j
        End If
    Next i
    If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
    Application.ScreenUpdating = True
End Sub
Sub SS_Show()
Subjects.Show
End Sub

     

    استدعاء بيانات بطريقه الفورمه 99(5).xlsb

    • Like 2

    برنامج لعمل كشوف الملاحظة

    في منتدى الاكسيل Excel

    قام بنشر

    برنامج لعمل كشوف الملاحظه لرجال التربيه والتعليم 

    Sub dub()
Application.ScreenUpdating = False
   On Error Resume Next
     If Sheets("data") Is Nothing Then
Sheets("source").Visible = True
    Sheets("source").Copy Before:=Sheets(3)
    ActiveSheet.Name = "data"
If ActiveSheet.Range("c3") > 3 Then
t = ActiveSheet.Range("c3") - 3
For i = 1 To t
    ActiveSheet.Columns("i:i").Select
    Selection.Copy
    Selection.Insert Shift:=xlToRight
Next
'Application.CutCopyMode = False
For n = 1 To ActiveSheet.Range("c3")
i = 11
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
ActiveSheet.Cells(i, x) = "المادة" & n
n = n + 1
Next
Next
End If
    'ActiveWorkbook.Names("المواد").Delete
'tt = ActiveSheet.Range("المواد") + 2
'End If
If ActiveSheet.Range("c2") > 10 Then
t = Application.WorksheetFunction.Round(((ActiveSheet.Range("c2"))) / 2, 0) - 5
For i = 1 To t
   Application.ScreenUpdating = False
   m = ActiveSheet.Range("last1").Row - 2
   ActiveSheet.Rows(m).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
Next
If ActiveSheet.Range("E4") = 1 Then
t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5 - 1
GoTo 77
Else
t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5
GoTo 77
End If
77:
For i = 1 To t
    m = ActiveSheet.Range("last2").Row - 2
   ActiveSheet.Rows(m).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown

Next

End If

 x = 2
  xx = 7
  i = 12 ' بداية صف المجموعة الاولي
  y = i + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 ' 22نهاية صف المجموعة الاولي
    
    ii = 6
    yy = ii + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 '16 نهاية صف النسخ

  iii = y + 3 '25 بداية صف المجموعة الثانية
  
      If ActiveSheet.Range("d4") = 1 Then
  yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1 ' 34نهاية صف المجموعة الثانية
  
Else
  yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0))  ' 35نهاية صف المجموعة الثانية
    End If
    
    
  iiii = yy + 1
      If ActiveSheet.Range("d4") = 1 Then
    yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1  ' 22نهاية صف المجموعة النسخ
  
    Else
    yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0))
End If

  ActiveSheet.Range(Cells(i, xx - 1).Address, Cells(y, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(ii, x - 1).Address, Cells(yy, x).Address).Value
ActiveSheet.Range(Cells(iii, xx - 1).Address, Cells(yyy, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(iiii, x - 1).Address, Cells(yyyy, x).Address).Value
  Application.CutCopyMode = True
color
ActiveSheet.Range("g12").Select
    ActiveWorkbook.Names("المواد").Delete
    tt = ActiveSheet.Range("c3") + 7
mn = Cells(11, 8).Address
mo = Cells(11, tt).Address
    ActiveWorkbook.Names.Add Name:="المواد", RefersTo:=ActiveSheet.Range(mn, mo)
   Application.ScreenUpdating = False
    ActiveSheet.Range("C2:G5").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   ActiveSheet.Range("C2").Select
   Application.ScreenUpdating = True
   Application.CutCopyMode = False

   ' ="'data'!"$C$11:$V$11
Else
If MsgBox("هل تريد الاستمرار سيتم الغاء شيت Data", vbOKCancel, "officena- Go ?") <> vbOK Then Exit Sub
Application.DisplayAlerts = False
Sheets("Data").Delete
Application.DisplayAlerts = True
End If
 Sheets("source").Visible = False
Application.ScreenUpdating = True

End Sub
Sub h1()
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = 12  'بداية صف المجموعة الاولي
nb = Range("lastco").Column + 1
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row
Dim Low As Double
Dim High As Double

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 'End If
End If
End If
 End If
Next
Next
 
If Cells(b + 1, nb) < [e5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 'End If
 End If
End If
 End If
Next
 Next
  End If

 
 
If Cells(b + 1, nb) < [e5] Then
0:
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then

If Cells(i, xx) = "" And Cells(i, xx + 1) <> "ح" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
 
If Cells(b + 1, nb) < [e5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
If Cells(b + 1, nb) < [e5] Then GoTo 0





End Sub
Sub h2()
'If Range("c5") > 0 Then
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
e = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = e + 3 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
End If

nb = Range("lastco").Column + 1
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row
Dim Low As Double
Dim High As Double

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 'End If
End If
End If
 End If
Next
Next
 
If Cells(b + 1, nb) < [f5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 'End If
 End If
End If
 End If
Next
 Next
  End If

 
 
If Cells(b + 1, nb) < [f5] Then
0:
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then

If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
 
If Cells(b + 1, nb) < [f5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
If Cells(b + 1, nb) < [f5] Then GoTo 0




End Sub
Sub h1tem()
If Range("E2") <= 0 Then Exit Sub
If Range("g1") > 1 Then
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = 12  'بداية صف المجموعة الاولي
For Each cell In Range(Cells(12, 8).Address, Cells(b, a).Address)
If cell.Value = "" Or cell.Value = 0 Then
cell.Value = "ح"
End If
Next
End If
End Sub

Sub num1()
Dim Low As Double
Dim High As Double
[A1500] = ""
[a2000] = ""
ActiveSheet.Range("A1000") = ""
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
0:
m = Range("h12").Address
n = Cells(b, a).Address
'If ActiveSheet.CheckBox1.Value = 0 Then
'Range(m, n) = ""
'End If
Application.ScreenUpdating = False
'h1
For x = 8 To a
For i = 12 To b
For n = 1 To [c4]
Low = n
High = [c4]
n = Round(((High - Low) * Rnd() + Low), 0)
'If r <= a Then
'If n >= 1 Then
If Cells(i, x) = "" Then
If Cells(i, x - 1) <> n Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v = 0 And v1 = 0 Then
'On Error GoTo 88
'If Cells(i, x) = "" Then
Cells(i, x) = n
'End If
End If
'End If
End If
End If
Next
Next
Next 'tem1
For i = 12 To b
For x = 8 To a
For n = 1 To [c4]
Low = n
High = [c4]
n = Round(((High - Low) * Rnd() + Low), 0)
If Cells(i, x) = "" Then
If Cells(i, x - 1) <> n Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v < 2 And v1 = 0 Then
Cells(i, x) = n

End If
End If
End If
Next
Next
Next 'tem1
For i = 12 To b
For x = 8 To a
For n = 1 To [c4]
If Cells(i, x) = "" Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v <= 2 And v1 = 0 Then
Cells(i, x) = n

End If
End If
Next
Next
Next 'tem1
test
If ActiveSheet.CheckBox1.Value = False Then
If Range("bad") = 1 Then
m = Range("h12").Address
n = Cells(b, a).Address
Range(m, n) = ""
h1
GoTo 0
End If
End If
Application.ScreenUpdating = True
'End
'88:
'GoTo 1
End Sub
Sub num2()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
GoTo 10
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
For x = 8 To a
For i = 12 To d
For y = c To b
'If Range("E4") = 0 Then
If ActiveSheet.Cells(i, x) > 0 And ActiveSheet.Cells(i, x) <> "ح" Then

'GoTo 0
'Else
'If Range("E4") <> 0 Then
'If Cells(i, x) > 0 And Cells(i, x) <> "ح" And Cells(i, x) < Range("c4") Then
'GoTo 0
'End If
'End If
0:
bb = ActiveSheet.Cells(i, 7).Interior.ColorIndex
bc = ActiveSheet.Cells(i, 7).Font.ColorIndex
If vvvv = 1 Then GoTo 3

   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(y, 8).Address & ":" & ActiveSheet.Cells(y, a).Address), ActiveSheet.Cells(i, x).Value)
v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), ActiveSheet.Cells(i, x).Value)
If v = 0 And v1 = 0 Then
Dim Low As Double
Dim High As Double

Low = c
High = b + 10
r = Int((High - Low) * Rnd() + Low)
If r >= c And r <= b Then
If ActiveSheet.Cells(r, x) = "" Then
3:
vvc = 0
For Each cell In ActiveSheet.Range(Cells(r, 8).Address, ActiveSheet.Cells(r, a).Address)
If cell.Interior.ColorIndex = bb And cell.Font.ColorIndex = bc Then
vvc = vvc + 1
End If
Next
'If Range("E4") = 0 Then
If vvc <= ActiveSheet.Range("c5") Then
'GoTo 1
'Else
'If Range("E4") <> 0 Then
'If vvc < [c5] Then
'GoTo 1
'End If
1:
ActiveSheet.Cells(r, x) = ActiveSheet.Cells(i, x)
ActiveSheet.Cells(r, x).Interior.ColorIndex = bb
ActiveSheet.Cells(r, x).Font.ColorIndex = bc
End If
End If
End If
End If
End If
'End If
'End If
'End If
Next
Next
Next
End Sub
Sub test()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية
End If
Range("bad") = ""
i = d + 2
For x = 8 To a
If Cells(i, x) = "توزيع خاطئ" Then
Range("bad") = 1
End If
Next
'i = b + 2
'For x = 8 To a
'If Cells(i, x) = "توزيع خاطئ" Then
'Range("bad") = 1
'End If
'Next
End Sub
Sub color()

a = 8 + [c3] - 1 'عدد الاعمدة
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الاولي
c = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) + 2 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2  'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية
End If
m = Cells(12, 8).Address
n = Cells(d, a).Address
o = Cells(c, 8).Address
p = Cells(b, a).Address
For i = 12 To d
If Cells(i, 6) > 0 Then
If Cells(i, 6) > 56 Then
Cells(i, 7).Interior.ColorIndex = Cells(i, 6) - 56
Cells(i, 7).Font.ColorIndex = 3
Else
Cells(i, 7).Interior.ColorIndex = Cells(i, 6)
End If
End If
Next
Range(Cells(c, 6).Address, Cells(b, 7).Address).Interior.ColorIndex = xlNone
Range(o, p).Interior.ColorIndex = Range("g" & d).Interior.ColorIndex + 4
Range(m, n).Interior.ColorIndex = 35
Range(Cells(d + 1, 8).Address, Cells(d + 1, a).Address).Interior.ColorIndex = 37
Range(Cells(b + 1, 8).Address, Cells(b + 1, a).Address).Interior.ColorIndex = 38
End Sub
Sub tem1()
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = 12 To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4") + 10
0:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If Range("E4") < 0 Then
If v = 0 And v1 < ActiveSheet.Range("c5") Then
If n <= ActiveSheet.Range("c4") Then
ActiveSheet.Cells(bb, x) = n
End If
End If

End If

Next
End If
Next
End If
Next
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = 12 To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4")
1:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 And v1 <= [c5] + 1 Then
If n <= ActiveSheet.Range("c4") Then
If Cells(bb, Range("lastco").Row) <= Range("d3") Then
ActiveSheet.Cells(bb, x) = n
End If
End If
End If
Next
End If
Next
End If
Next
End Sub
Sub tem2()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = c To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To [c4] + 10
If n <= ActiveSheet.Range("c4") Then
0:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 Then
ActiveSheet.Cells(bb, x) = n
For hh = 12 To d
If ActiveSheet.Cells(hh, x) = n Then
cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex
bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex
GoTo fl
End If
Next
fl:
ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc
ActiveSheet.Cells(bb, x).Font.ColorIndex = bc
End If
End If
Next
End If
Next
End If
Next
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = c To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4") + 10
If n <= ActiveSheet.Range("c4") Then
1:
   v = Application.WorksheetFunction.CountIf(Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 And v1 <= 2 Then
ActiveSheet.Cells(bb, x) = n
For hh = 12 To d
If ActiveSheet.Cells(hh, x) = n Then
bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex
cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex
GoTo cl
End If
Next
cl:
ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc
ActiveSheet.Cells(bb, x).Font.ColorIndex = bc
End If
End If
Next
End If
Next
End If
Next
End Sub
Sub allone1()
m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 8).Address
n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 11).Address
Range(m, n) = ""
a = 3 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1)  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 9).Column
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, x).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = Cells(i, 2)
.Offset(1, 1) = Cells(i, x)
.Offset(1, 2) = Cells(11, x)
End With
End If
Next
Next
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = 12 To d
If Cells(i, 2).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 8) = Cells(i, 2)
If Cells(i, x) = "ح" Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = "-"
.Offset(1, 1) = "ح"
.Offset(1, 2) = Cells(11, x)
End With
End If
End If
Next
Next
End Sub
Sub allone2()
m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 13).Address
n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 16).Address
Range(m, n) = ""
a = 8 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("d4") > 0 Then
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1)  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 14).Column
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2)
If Cells(i, x) <> "ح" Then
For n = 12 To d
If Cells(n, 7).Interior.ColorIndex = Cells(i, x).Interior.ColorIndex Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = Cells(n, 2)
.Offset(1, 1) = Cells(n, x)
.Offset(1, 2) = Cells(11, x)
End With
End If
Next
End If
End If

Next
Next
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2)
If Cells(i, x) = "ح" Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = "-"
.Offset(1, 1) = "ح"
.Offset(1, 2) = Cells(11, x)
End With
End If
End If
Next
Next

End Sub
Sub xxxcc()
'If Target.Column = 19 And Target.Row = 9 Then
Range("t10:y210") = ""
'If Target <> "" Then
i = 11
For x = 8 To Sheets("data").Range("c2") - 1
If Sheets("data").Cells(i, x) = Sheets("شيت طبع كشف الملاحظة").Range("s9") Then
z = Sheets("data").Cells(i, x).Column
GoTo 0
End If
Next


0:
For y = 12 To d
If IsNumeric(Sheets("data").Cells(y, z)) And Sheets("data").Cells(y, z) > 0 And Sheets("data").Cells(y, 2) <> "" Then ' Sheets("شيت طبع كشف الملاحظة").Cells(yy, 1) Then
With Columns(20).Rows(210).End(xlUp)
.Offset(1, 0) = Sheets("data").Cells(y, z)
.Offset(1, 1) = Sheets("data").Cells(y, 2)
End With
End If
Next
For yyy = 12 To d
If Sheets("data").Cells(yyy, z) = "ح" Then
With Columns(22).Rows(210).End(xlUp)
.Offset(1, 0) = Sheets("data").Cells(yyy, z)
.Offset(1, 1) = Sheets("data").Cells(yyy, 2)
End With
End If
Next

End Sub
Function aahsum(aa As Variant)
f = 0
For n = 1 To aa.Value
f = f + n
Next
aahsum = f
End Function

     

    برنامج ساقبة اللجان.xlsb

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

    في منتدى الاكسيل Excel

    قام بنشر

      

    Sub Test_A()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 5, 6)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
 
End Sub

Sub Test_B()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 8, 9)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_C()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 11, 12)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'---------------------------------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'-----------------------------------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_D()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 14, 15)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'-----------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'-----------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_E()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 17, 18)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_F()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 20, 21)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_G()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 23, 24)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_H()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
'-----------------------------------------
Set Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 26, 27)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub SS_Show()
Subjects.Show
End Sub

     

    استدعاء بيانات بطريقه الفورمه.xlsb

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

    • Like 1

    مساعد ادخال لبرنامج ASC الرائع لتوزيع حصص المدرسين للعلامه عبد الله باقشير ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

     

    طريقة الاستعمال

    يوجد صفحه اسمها الخطة 

    اكتب فيها اسماء المواد المطلوبه

    ثم اكمل تسجيل نصاب كل مدرس من واقع الخطه المدرسيه

    في نفس الصفحه الخطة

    انتقل الي  صفحه الفصول ستجدها منظمه حدد البانات فيها ثم انسخها

    انتقل الي برنامج الجدول المدرسي والصق المنسوخ في البرنامج

    طريقه من طرق الادخال سهله ودقيقه

    يحفظ ربنا ويبارك

    للعلامه عبد الله باقشير

    وكل من في المنتدى المحترم

    • Like 2

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    تغير الخط في الخليه النشطه 

    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
Application.ScreenUpdating = False
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't restore
For i = 1 To cnNUMCOLS
If nColorIndices(i) = xlNone Then
.Item(i).Interior.ColorIndex = xlNone
Else
.Item(i).Interior.Color = nColorIndices(i)
End If
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.Color
If .Item(i).Interior.ColorIndex = xlNone Then
nColorIndices(i) = xlNone
Else
nColorIndices(i) = .Item(i).Interior.Color
End If
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
Application.ScreenUpdating = True
End Sub

     

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

    تكبير الخط في الخليه النشطه بعدة طرق.xlsb

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    كود بطريقه أخري لتوزيع كشوف المناداه 

    Private Sub Worksheet_Change(ByVal Target As Range)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
st = 0
s = 0
lo = 0
lr = 0
k = 0
b = 0
'خليه عدد اللجان
If Target.Address = "$N$11" Then
s = 1
'عمود المسلسل
lr = Range("a" & Rows.Count).End(xlUp).Row

'خليه عدد الطلبه في بيان اللجان
st = Cells(9, 13).Value

'خليه عدد اللجان في بيان اللجان
lo = Cells(9, "n").Value

'خليه باقي الطلبه في بيان اللجان
b = Cells(9, "o").Value

While b >= lo
st = st + 1
b = b - lo
Wend
k = st
If b > 0 Then
st = st + 1
End If

'الصف الاول للاسماء
For i = 8 To lr
If Cells(i, 1).Row - 7 <= st Then
Cells(i, 4) = s
Else
s = s + 1

'رقم عمود رقم اللجنه
Cells(i, 4) = s
If b > 0 Then b = b - 1
If b > 0 Then
st = st + 1
End If
st = st + k
End If
Next
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Target.HasFormula = True Then
'ActiveCell.Offset(0, 1).Select
'MsgBox ("يوجد هنا معادلات ")
'End If
End Sub

     

    كشف منادة الصف الثالث1.xlsb

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    البحث بالاســم أو رقم الجلوس 

    Private Sub ComboBox1_Change()

End Sub

Private Sub CommandButton1_Click()
Dim ws As Worksheet, SC As String
Dim y As Range, x As Range
Set ws = Sheets("SH")
SC = Search.ComboBox1.Text
RG = Search.TextBox2.Value
If SC = "" Then Shihada.Show
If SC = "" Then Exit Sub
For Each y In ws.Range("C12:C" & ws.Range("C" & Rows.Count).End(xlUp).Row)
If y.Value = SC Then
ws.Activate
y.Select
Search.TextBox2.Value = ActiveCell.Offset(0, -1)
Shihada.Label1.Caption = ActiveCell.Offset(0, -1)
Shihada.Label2.Caption = ActiveCell.Offset(0, 0)
Shihada.Label3.Caption = ActiveCell.Offset(0, 2)
Shihada.Label4.Caption = ActiveCell.Offset(0, 8)
Shihada.Label5.Caption = ActiveCell.Offset(0, 18)
Shihada.Label6.Caption = ActiveCell.Offset(0, 28)
Shihada.Label7.Caption = ActiveCell.Offset(0, 39)
Shihada.Label8.Caption = ActiveCell.Offset(0, 51)
Shihada.Label9.Caption = ActiveCell.Offset(0, 59)
Shihada.Label10.Caption = ActiveCell.Offset(0, 63)
Shihada.Label11.Caption = ActiveCell.Offset(0, 68)
Shihada.Label12.Caption = ActiveCell.Offset(0, 73)
Shihada.Label13.Caption = ActiveCell.Offset(0, 78)
Shihada.Label14.Caption = ActiveCell.Offset(0, 83)
Shihada.Label15.Caption = ActiveCell.Offset(0, 89)
Shihada.Label16.Caption = ActiveCell.Offset(0, 99)
Shihada.Label17.Caption = ActiveCell.Offset(0, 109)
Shihada.Label18.Caption = ActiveCell.Offset(0, 9)
Shihada.Label19.Caption = ActiveCell.Offset(0, 19)
Shihada.Label20.Caption = ActiveCell.Offset(0, 29)
Shihada.Label21.Caption = ActiveCell.Offset(0, 40)
Shihada.Label22.Caption = ActiveCell.Offset(0, 52)
Shihada.Label23.Caption = ActiveCell.Offset(0, 60)
Shihada.Label24.Caption = ActiveCell.Offset(0, 64)
Shihada.Label25.Caption = ActiveCell.Offset(0, 69)
Shihada.Label26.Caption = ActiveCell.Offset(0, 74)
Shihada.Label27.Caption = ActiveCell.Offset(0, 79)
Shihada.Label28.Caption = ActiveCell.Offset(0, 84)
Shihada.Label29.Caption = ActiveCell.Offset(0, 90)
Shihada.Label30.Caption = ActiveCell.Offset(0, 100)
Shihada.Label31.Caption = ActiveCell.Offset(0, 110)
Shihada.Label32.Caption = ActiveCell.Offset(0, 117)
Search.ComboBox1.Text = ""
Search.TextBox2.Value = ""
End If
Next
Shihada.Show
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub UserForm_Initialize()
Dim ws As Worksheet
Set ws = Sheets("SH")
ws.Range("C12:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Name = "Sors"
ComboBox1.RowSource = "Sors"
End Sub

     

    البحث بالاسـم أو زقم الجلوس.xlsb

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    يبارك فيكم ربنا 

    Sub استخراج_حالة_الطالب()
    Dim ARR
    Dim ARRY
    Dim ARRYS
    '___________________________________________
    Dim R As Long
    Dim X As Long
    Dim XX As Byte
    Dim ALL_LESS As String
    Dim Main As Worksheet
    Dim Info As Worksheet

    Set Main = Sheets("رصد الترم الثانى")
    Set Info = Sheets("بيانات المدرسة")

    '___________________________________________
    Const STATUS As Byte = 133    'عمود الحالة ناجح او دور ثان
    Const NOTES As Byte = 134  ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
    Const GENDER As Byte = 141  ' عمود الجنس ذكر او أنثى
    Const TOTAL  As Byte = 98
    Const LESS_ROW As Byte = 6  'صف الدرجة الصغرى
    Const NAM_ROW As Byte = 2    'صف اسماء المواد
    Const NAME_FIRST As Byte = 6  ' (اول صف لاسماء الطلاب -1)
    Const Absent  As Byte = 12    'عدد المواد لحساب الغياب
    Dim NAME_LAST As Long: NAME_LAST = Info.Range("B10").Value + NAME_FIRST   ' عدد الطلاب
   '======
    '_____________________________________________________
    'اعمدة اختبار الترم التاني
    'رقم عمود المجموع يكتب هنا
  ARR = Array(10, 21, 32, 43, 135, 65, 72, 79, 86, 93, 105, 98)
    
    'اعمدة الدرجة النهائية
    'ايضارقم عمود المجموع يكتب هنا
    ARRY = Array(14, 25, 36, 47, 60, 68, 75, 82, 89, 96, 109, 98)
    
    'اعمدة اسماء كل المواد
    'ايضارقم عمود المجموع يكتب هنا
    ARRYS = Array(5, 16, 27, 38, 49, 63, 70, 77, 84, 91, 100, 98)
   '=================
   With Main    'اسم شيت البيانات
        Application.ScreenUpdating = False    'الغاء تحديث الشاشة
        Application.Calculation = xlManual    ' ايقاف الحساب التلقائي
        For R = NAME_FIRST To NAME_LAST    ' حلقة تكرارية تبدأ  بأول اسم طالب الى اخر اسم
            For X = 0 To UBound(ARR)    ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني
                On Error Resume Next
                '____________________________________________________
                'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس
                'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب
                If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then
                    XX = XX + 1
                End If
                '___________________________________________________
                 If ARR(X) = TOTAL Then
                    'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل
                    If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Then
                        ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لنصف الدرجة " & " - ": GoTo 86
                        GoTo 86
                   Else
                        GoTo 86
                   End If
                End If
                '____________________________________________________
  
                'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف  المواد الى المتغير
                'ALL_LESS
                'او  مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير
                'ALL_LESS
                '______________________________________________________
                If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86
                End If
                If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
                End If
                '______________________________________________________
86          Next X    'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد
             'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب
          If XX = Absent Then ALL_LESS = "غياب  ": XX = 0

            '_____________________________________________________
            'هنا بعد اكتمال الكود يتم عمل شرط للمتغير
            'ALL_LESS
            'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح
            If ALL_LESS = "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "ناجح "    'اذا كان نوع الطالب ذكر يتم وضع ناجح
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "ناجحة "    'اذا كانت أنثى يتم وضع ناجحه
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, NOTES) = "ومنقول " & Info.Range("B16")    'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, NOTES) = "ومنقولة " & Info.Range("B16")    'مثل ماسبق
                'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان
            ElseIf ALL_LESS <> "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "له دور ثان في"    'مثل ما سبق بخصوص النوع
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "لها دور ثان في"    '
                .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2)    'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات
                ALL_LESS = Empty    'تفريغ المتغير لاعادة تعبئة اسم طالب اخر
            End If
            '_____________________________________________________
        Next R    'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب
    End With
    Application.ScreenUpdating = True    'اعادة تحديث الشاشة
    Application.Calculation = xlAutomatic    'تشغيل الحساب التلقائي
End Sub

     

    استخراج حالة الطالب ومواد الرسوب نسخه منقحه2.xlsb

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    اظهاز طلاب الدور التاني 

    
'هذا الكود للمحترم النابغه ياسر خليل
'  الهدف من الكود هو استدعاء بشرط من خارج الكود
'تم هذا الكود في 15/2/2017
'==*==*==*==*==*==*==*==*==*==*
    Sub كشوف_كنترول_ثان()
   ActiveSheet.Unprotect
    Dim Arr     As Variant
    Dim Arry    As Variant
    Dim Lr      As Long
    Dim i       As Long
    Dim J       As Long
    Dim Main As Worksheet
    Dim sh As Worksheet
    Dim NUM1 As Integer
    Dim NUM2 As Integer

    Dim Trgt1 As String
    Dim Trgt2 As String
    
     'رقم عمود البحث
    NUM1 = 133    'عمود الشرط الاول
    NUM2 = 144    'عمود الشرط الثاني

    '=*=*=*=*=*=*=*=*=*=*=*=*
    Set Main = Sheets("رصد الترم الثانى")
    Set sh = Sheets("كشوف الترم الأول")
    
    'خليه البحث
    Trgt1 = sh.Range("D1") & "*"    'الشرط الاول
    Trgt2 = sh.Range("E1").Value    'الشرط الثاني

     On Error Resume Next
     
     'مدى المسح في صفحه الهدف
'===========================================================
    sh.Range("A7:AM1000").ClearContents
'===========================================================
    
    Lr = Main.Cells(Rows.Count, 1).End(xlUp).Row

'===========================================================
    Arr = Main.Range("A7:GB" & Lr).Value
'===========================================================
         'مدى  صفحه الهدف
     Arry = sh.Range("A7:AM1000")
    
    J = 1
    For i = LBound(Arr, 1) To UBound(Arr, 1)
    
        'رقم عمود البحث
     'If arr(i, NUM1) Like Trgt1 Then
     'If arr(i, NUM1) Like Trgt1 & "*" Then
      If Arr(i, NUM1) Like Trgt1 & "*" And Arr(i, NUM2) Like Trgt2 Then

'===========================================================
                 Arry(J, 1) = J
                'العمود الاول بعد المسلسل
                 Arry(J, 2) = Arr(i, 2)
                 Arry(J, 3) = Arr(i, 3)
                 Arry(J, 4) = Arr(i, 140)
                 Arry(J, 5) = Arr(i, 142)
                 Arry(J, 6) = Arr(i, 143)
                 Arry(J, 7) = Arr(i, 14)
                 Arry(J, 8) = Arr(i, 15)
                 Arry(J, 9) = Arr(i, 25)
                 Arry(J, 10) = Arr(i, 26)
                 Arry(J, 11) = Arr(i, 36)
                 Arry(J, 12) = Arr(i, 37)
                 Arry(J, 13) = Arr(i, 47)
                 Arry(J, 14) = Arr(i, 48)
                 Arry(J, 15) = Arr(i, 60)
                 Arry(J, 16) = Arr(i, 61)
                 Arry(J, 17) = Arr(i, 68)
                 Arry(J, 18) = Arr(i, 69)
                 Arry(J, 19) = Arr(i, 75)
                 Arry(J, 20) = Arr(i, 76)
                 Arry(J, 21) = Arr(i, 82)
                 Arry(J, 22) = Arr(i, 83)
                 Arry(J, 23) = Arr(i, 89)
                 Arry(J, 24) = Arr(i, 90)
                 Arry(J, 25) = Arr(i, 96)
                 Arry(J, 26) = Arr(i, 97)
                 Arry(J, 27) = Arr(i, 98)
                 Arry(J, 28) = Arr(i, 99)
                 Arry(J, 29) = Arr(i, 99)
                 Arry(J, 30) = Arr(i, 109)
                 Arry(J, 31) = Arr(i, 110)
                 Arry(J, 32) = Arr(i, 131)
                 Arry(J, 33) = Arr(i, 132)
                 Arry(J, 34) = Arr(i, 133)
                 Arry(J, 35) = Arr(i, 134)
'===========================================================
            
            J = J + 1
        End If
    Next i
    With sh
        
'===========================================================
        'خليه بدايه اللصق
        .Range("B7").Resize(J - 1, UBound(Arry, 2)).Value = Arry
         'مدى المسح في صفحة الهدف
        .Range("A7:AM" & Rows.Count).Borders.Value = 0
'===========================================================
        
        'سطر لاضافة التسطير
        .Range("B7:AM" & .Cells(Rows.Count, 4).End(xlUp).Row).Borders.Value = 1
    End With
         Erase Arr
     Erase Arry

    ActiveSheet.Protect
End Sub

     

    • Like 2

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    كود التنقل بين الصفحات 

    Sub SheetList_CP()
    Application.CommandBars("Workbook Tabs").ShowPopup
        Range("A1").Select
End Sub

     

    طباعه ارقام معينه بالنسبه للتيكيت 

    
Private Sub CommandButton1_Click()
    Dim X As Long, Y As Long, Z As Byte
    ' وضع قيمة التكست بوكس 2 داخل المتغير Y
    Y = TextBox2.Value
    ' وضع قيمة التكست بوكس 3 داخل المتغير Z
    Z = TextBox3.Value
    'حلقة تكرارية بداية من التكست بوكس 1 الى المتغير واي  الذي يحمل قيمة التكست2
    For X = TextBox1.Value To Y
        'هنا يتم وضع ارقام الجلوس تباعا لكل خلية من التسع خلايا
        'اول خلية تساوى المتغير اكس والذي يحمل ارقام الجلوس التى حددناها من قبل
        'والخلية التالية نضع املتغير اكس بالاضافة الى واحد ليحمل رقم الجلوس التالي
        'وهكذا مع الخلايا الاخرى الخاصة بارقام الجلوس
        'اما الشروط المضافة بجانب الخلايا IF[]>y then []=""
        'فهذه تم وضعها فقط للتأكد من ان قيمة الخلايا لا تزيد عن اخر رقم جلوس وهو ما يحمله المتغير واي
        'فاذا تحقق الشرط وكان رقم الجلوس اكبر من اخر رقم يتم مسحه وهذه الشروط لا نستعملها الا في اخر صفحة يتم طباعتها
        [B8] = X: If [B8] > TextBox2.Value Then [B8] = ""
        [B14] = X + 3: If [B14] > Y Then [B14] = ""
        [B20] = X + 6: If [B20] > Y Then [B20] = ""
        [B26] = X + 9: If [B26] > Y Then [B26] = ""
        [B32] = X + 12: If [B32] > Y Then [B32] = ""
        [B38] = X + 15: If [B38] > Y Then [B38] = ""

'============
        [H8] = X + 1: If [H8] > Y Then [H8] = ""
        [H14] = X + 4: If [H14] > Y Then [H14] = ""
        [H20] = X + 7: If [H20] > Y Then [H20] = ""
        [H26] = X + 10: If [H26] > Y Then [H26] = ""
        [H32] = X + 13: If [H32] > Y Then [H32] = ""
        [H38] = X + 17: If [H38] > Y Then [H38] = ""
        
'============
        [N8] = X + 2: If [N8] > Y Then [N8] = ""
        [N14] = X + 5: If [N14] > Y Then [N14] = ""
        [N20] = X + 8: If [N20] > Y Then [N20] = ""
        [N26] = X + 11: If [N26] > Y Then [N26] = ""
        [N32] = X + 14: If [N32] > Y Then [N32] = ""
        [N38] = X + 17: If [N38] > Y Then [N38] = ""

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


        'سطر الطباعة وعدد النسخ تساوي z
        'والتى تساوي تكست بوكس تلاته التى نضع بها عدد النسخ المطلوبة
        ActiveWindow.SelectedSheets.PrintOut Copies:=Z    ', Preview:=True
        'هنا نقوم باضافة ثمانية ارقام الى المتغير اكس ليصبح محموعهم 9 ليتخطى تسع ارقام جلوس كل دورة
        'داخل الحلقة التكرارية حتى نهاية الحلقة
        X = X + 18
        'نكست اي يعود مرة اخرى لاول الحلقة التكرارية لتطبيق الاكواد مرة اخرى
    Next
   ' MsgBox "Done.....", 64
    Me.Hide
End Sub
Private Sub UserForm_Activate()
'هنا في حدث تنشيط الفورم
'تكست واحد تساوى اول رقم جلوس
    TextBox1.Text = Sheets("بيانات الطلبة").Range("B7").Value
    'تكست2 تساوي اخر رقم جلوس
    TextBox2.Text = Sheets("بيانات الطلبة").Range("B" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value
End Sub

     

    • Like 1

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    استدعاء كشوف اللجان 

    Sub Legan_Test()
     ActiveSheet.Unprotect Password:="1"

    Dim Main          As Worksheet
    Dim sh          As Worksheet
    Dim Arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim Lr          As Long
    Dim i           As Long
    Dim J           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long
    '=======================
    'اسم صفحة المصدر
    Set Main = Sheets("بيانات الطلبة")

    'اسم صفحة الهدف
    Set sh = Sheets("كشوف المناداة ")

    Lr = Main.Cells(Rows.Count, 5).End(xlUp).Row
    
        Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    'مدى المسح في كشفي اللجان
        sh.Range("C10:F46").ClearContents
        sh.Range("K10:N46").ClearContents
        sh.Rows("10:46").Hidden = False
        
        'مدى صفحة المصدر
        Arr = Main.Range("A7:V" & Lr).Value
        
        'الاعمده المطلوب نقلها من صفحه المصدر
        arrC = Array(2, 5, 15, 16)
        ReDim temp1(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(Arr)
        
        'رقم عمود رقم اللجان في صفحه المصدر
            If Arr(i, 18) = sh.Range("E3").Value Then
                p1 = p1 + 1
                For J = 0 To UBound(arrC)
                    temp1(p1, J) = Arr(i, arrC(J))
                Next J
            End If
            If Arr(i, 18) = sh.Range("M3").Value Then
                p2 = p2 + 1
                For J = 0 To UBound(arrC)
                    temp2(p2, J) = Arr(i, arrC(J))
                Next J
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        
        'لاخفاء الصفوف الفارغه في كشف اللجان
        If k < 46 Then sh.Rows(k & ":46").Hidden = True
             Erase temp1
     Erase temp2

         ActiveSheet.Protect
        Application.Visible = True
            Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

  '  Application.Calculation = xlManual
   ' Application.EnableEvents = False
    'Application.ScreenUpdating = False

     

    طباعه كشوف اللجان 

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

     

    طباعه لجنه واحده من كشوف المناداه 

    '*****************************
Sub طباعه_لجنه()
Dim LatR As Long
LatR = Range("D:D").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
With ActiveSheet
    .PageSetup.PrintArea = "A4:O" & LatR
    .PrintOut
End With
End Sub

     

    • Like 1

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    هذا كود لحمايه ملف اكسيل

      

    
Sub Protec()
' قبل وضع الكود  ...
'لابد من جعل الخلايا كلها
'unlocked
'حدد خلايا ورقة العمل بالكامل
'ثم كليك يمين ثم اختار آخر تبويب
'ثم أزيل علامة الصح بجانب الخيار
'Lock وكذلك Hidden
'=================
Application.ScreenUpdating = False
    Dim mySheet As Worksheet
    Dim myPassword As String
    
    With Application
        .DisplayFullScreen = False
        .CommandBars("Worksheet Menu Bar").Enabled = True
        .CommandBars("Standard").Visible = True
        .CommandBars("Formatting").Visible = True
        .DisplayFormulaBar = True
        .DisplayStatusBar = False
    End With
    
    myPassword = ""
    
    On Error Resume Next
        For Each mySheet In ActiveWorkbook.Sheets
            With mySheet
                .Unprotect myPassword
                .Cells.Locked = False
                .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
                .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
                .Protect myPassword
            End With
        Next mySheet
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

     

    هذا كود فك الحمايه 

    
Sub Protec()
' قبل وضع الكود  ...
'لابد من جعل الخلايا كلها
'unlocked
'حدد خلايا ورقة العمل بالكامل
'ثم كليك يمين ثم اختار آخر تبويب
'ثم أزيل علامة الصح بجانب الخيار
'Lock وكذلك Hidden
'=================
Application.ScreenUpdating = False
    Dim mySheet As Worksheet
    Dim myPassword As String
    
    With Application
        .DisplayFullScreen = False
        .CommandBars("Worksheet Menu Bar").Enabled = True
        .CommandBars("Standard").Visible = True
        .CommandBars("Formatting").Visible = True
        .DisplayFormulaBar = True
        .DisplayStatusBar = False
    End With
    
    myPassword = ""
    
    On Error Resume Next
        For Each mySheet In ActiveWorkbook.Sheets
            With mySheet
                .Unprotect myPassword
                .Cells.Locked = False
                .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
                .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
                .Protect myPassword
            End With
        Next mySheet
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

     

    • Like 1

    مجموعة أكواد ولاأروع

    في منتدى الاكسيل Excel

    قام بنشر

    هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا

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

    فجزى الله كل من كانت له بصمه في هذا العمل

     

    كنترول محمدي9.xlsb

    كلمة سر فتح البرنامج 111

    • Like 3
×
×
  • اضف...

Important Information

  I accept