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

وعليكم السلا م ورحمة الله وبركاته ..تفضل جرب المرفق بحث برقم الجلوس.xlsm

وعليكم السلام > نعم كما اخبرك استاذنا محسن مهند طلبك موجود بكثرة لو استخدمت خاصية البحث . عل كل حال وجدت لك فورم من المتتدى لصاحبه عبدالله باقشير جعله الله في ميزان حسناته وطبقته على ملفك فيه البحث بما تشاء والتعديل والاضافة والحذف والطباعة لو اتقنت استخدامه لن تحتاج الى غيره ان شاء الله قسم الحركة10-2022.xlsm

الكوود المرتبط بزر الطباعة 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 Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("A1").Resize(LastColumn, 2) .ColumnWidth = 35 .Borders.LineStyle = 1 .PrintPreview End With .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 اما باقي اكواد الفورم فربمما الكود في الاعلى مرتبط بباقي الاكواد Option Explicit '====================================================== '====================================================== ' ÊäÓíÞ ÇáÊÇÑíÎ Private Const DtF As String = "yyyy/mm/dd" '====================================================== ' ÚõÑÖ ÊÇßÓÊ ÇáÇÏÎÇá Private Const iWgt1 As Single = 200 '====================================================== Private Const Frmtop As Single = 3 Private Const Frmlft As Single = 3 Private Const iHgt As Single = 21.55 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, iColor2 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 ButtonCalendar_Click() On Error GoTo 1 Dim MyVelue, t With Me.Frame1 If .ActiveControl Is Nothing Then .SetFocus If TypeOf .ActiveControl Is MSForms.TextBox Then .ActiveControl.BackColor = Me.ButtonCalendar.BackColor If .ActiveControl.Top > .Height Then .ScrollTop = .ActiveControl.Top - (.Height / 2) MyVelue = .ActiveControl t = .Controls(.ActiveControl.TabIndex + 1) If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then Else MyVelue = Date With FormDate .Caption = t .Tag = MyVelue .Show End With .ActiveControl.BackColor = &HFFFFFF Else MsgBox "áÇ íãßä ÇÖÇÝÉ ÇáÊÇÑíÎ Ýí ÞÇÆãÉ", mBox, "ÊäÈíå" End If End With 1 If Err Then Err.Clear 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 Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("A1").Resize(LastColumn, 2) .ColumnWidth = 35 .Borders.LineStyle = 1 .PrintPreview End With .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 '''''''''''''''''''''''''' For Each ctl In Me.Controls If ctl.Parent.Name <> "Frame1" Then If ctl.Name <> "Frame1" Then ctl.Visible = v End If Next '''''''''''''''''''''''''' For Each ctl In Me.Frame1.Controls If TypeOf ctl Is MSForms.ComboBox Then ctl.ShowDropButtonWhen = IIf(v, 2, 0) End If Next 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 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 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 = 16761024 .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 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' End Sub Private Sub UserForm_Initialize() 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_Terminate() Set MyRngdate = Nothing Erase Ar Unload FormDate End Sub

السلام عليكم في الملف المرفق فيه طلبك ان شاء الله الملف الاصلي وهو من كنوز المنتدى فورم ادخال و تعديل مرن مع الطباعة 1.xls

وعليكم السلام اتمنى ان يكون طلبك بواسطة كود بين تاريخين.xlsb

السلام عليكم جرب المرفق تقييم الصف السادس.xls

وعليكم السلام ورحمة الله وبركاته g1 = Range("H13").Value غير من g1 الى g2 تحياتي

تفضل اخونا الفاضل New Microsoft Excel Worksheet (3).xlsx

معادلة استاذنا الفاضل ابراهيم الجداد سليمة 100% شيت.xlsx

وعليك السلام ورحمة الله وبركاته الخطوات افتج محرر الاكواد ثم الفورم ثم غير الخاصية كما بالصورة

حفظك الله اخي الفاضل ولك كل تقديري واحترامي

وعليكم السلام ورحمة الله وبركاته جرب هذه المحاولة تقارير.xlsm

1106650381_-(1).xlsm

اخي الفاضل افادك الله كما افدتنا وجزاك الله كل خير الخطأ ليس لغوي بل برمجي فيجب ان تكون الكلمة متوافقة في القائمة المنسدلة في الخلية B2 مغ الكلمة الموجودة في الكود بمعنى مبسط اذا كانت كلمة أبريل في القائمة المسدلة بالفتحة فيجب ان تكون في الكود نفسها بالفتحة واذا كانت كلمةإبريل في القائمة المسدلة بالكسرةفيجب ان تكون في الكود نفسها بالكسرة واذا كانت كلمة ابريل بدون كسرة ولا فتحة فيجب ان تكون في الكود مثلها بمعنى التطابق التام في شكل اي كلمة بما في القائمة والكود حفظك الله ورعاك

يمكنك تعطيل الماكرو من خيارات ومركز الثوتيق والدخول الى محرر الاكواد ومعرفة الرقم السري على كل حال جرب 1984

اولاأيوجد خطأ بالكود قم بتعديل كلمة إبريل الى أبريل بالكود بملفك كالتالي Case Is = "إبريل": kh_ColumnHidden "FC:FV" الى Case Is = "أبريل": kh_ColumnHidden "FC:FV" ثانيا لضمان الحقوق وكما اشرت في مشاركتى بالاعلي ان الكود من المنتدى وهو للعلامة اخونا من اليمن (وقاها الله وحفظ اهلها من الفتن والحروب ) الاستاذ عبدالله باقشير ثالتا ساحاول ان اشرح الكود الكود يتكون من جزء رئيسي وهو يتم اخفاء كل الاعمدة من العمود Gالى الى اخر عمود XFD بمعني اخفاء كل الاعمدة بالصفحة عد1 الخمسة الاعمده الاولي والتي بها الاسم وايام الحضور الخ Sub kh_ColumnHidden(ColumnAddres As String) ' الغاء اهتزاز الشاشة Application.ScreenUpdating = False ' الصفخة المراد تطبيق الكود عليها Sheets("الحضور والغياب").Select ' اخفاء الاعمدة من العمود G الى اخر عمودXFD Columns("G:XFD").EntireColumn.Hidden = True Columns(ColumnAddres).EntireColumn.Hidden = False End Sub بعد اخفاء جميع الاعمدة عدا الخمسة الاولي سنقوم باظهار الاعمدة التي نحتاجها If Not Application.Intersect(Range("B2"), Range(Target.Address)) Is Nothing Then Select Case Target.Value Case Is = "سبتمبر": kh_ColumnHidden "G:AB" Case Is = "أكتوبر": kh_ColumnHidden "AC:AW" Case Is = "نوفمبر": kh_ColumnHidden "AX:BS" Case Is = "ديسمبر": kh_ColumnHidden "BT:CO" Case Is = "يناير": kh_ColumnHidden "CP:DK" Case Is = "فبراير": kh_ColumnHidden "DL:EE" Case Is = "مارس": kh_ColumnHidden "EF:FB" Case Is = "أبريل": kh_ColumnHidden "FC:FV" Case Is = "مايو": kh_ColumnHidden "FW:GS" السطر الاول B2 وهي الخلية التي يتم اختيار الشهر منها Select Case Target.Value يتم اختيار الحالة (الشهر) حسب القيمة اي قيمة B2 Case Is = "سبتمبر": kh_ColumnHidden "G:AB" في حالة B2 تساوي ستمبر قم باظهار الاعمدة من "G:AB" فلو ذهبت الى شيت الحضور والغياب لوجدت شهر سبتمبر يبدأ من العمو د G وينتهي عند العمود AB وهكذا لبقية الاشهر اتمنى اني قدمت ما يفيدك

وعليكم السلام ورحمة الله بركاته من خلال التجربة كود استاذنا الفاضل بن عليه سريع جدا اما طول الكود فتم اختصاره بكود من المنتدى وكما يقال كل الطرق تؤدي الى روما . فكود السيد بن عليه والكود المختصر يؤديان نفس النتيجة تحياتي كشف حضور وغياب1.xlsm

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

وعليكم السلام ورحمة الله وبركاته هذا الموضوع به طلبك ان شاء الله https://www.officena.net/ib/topic/66864-استدعاء-فورم-عن-طريق-رقم-سري/#comment-434812

تستحقها عن جدارة الف مبارك وفقك الله

بارك الله بك ولك اضعاف ما دعوت لي جرب الملف المرفق البرنامج الجديد 2021 (1) (12) (6).xlsm

وعليكم السلام ورحمة الله وبركاته قم بتظليل عمود التاريخ تم انقر الفارة اليمين تظهر قائمة منسدلة اختر منها تنسيق خلايا ثم من القائمة الاخرى اختر تاريخ بالنسبة لمعاينة الطباعة قم باستبدال كلمة PrintOut بـ PrintPreview بالكود تحياتي

قم بنغيير اسم الشيت كما افاد استاذنا عبد الفتاح

Sub COPYPASTE() ActiveCell.Copy Range("C9").Select Sheets("SHEET2").Select Range("C8").Select ActiveSheet.Paste End Sub