نجوم المشاركات

وعليكم السلام-جرب هذه المعادلة =SUMIF($B$13:B14,$B14,$D$13:D14) Book2.xlsx

وعليكم السلام-وده من خلال Data Validation بإستخدام هذه المعادلة =AND($E2="",$F2="",$G2="") حجب 1الخلايا.xlsx

الحقيقة اننا خسرنا الكثير باغلاق المنتديات المتخصصة ولكوني معاصر لبداية وازدهار وافول العديد منها من خلال عملي سابقا في برمجة الهاكات لمنتديات vBulletin فسوف اتحدث عن بعض الاسماء التي تشرفت بمزاملتها خلال تلك الفترة احد اعضاء منتديات المشاغب قام بتعريب اكثر من 400 برنامج واعتمدت تعريباته من الشركات المنتجة لهذه البرامج وحتى هذا اليوم رغم مرور اكثر من عشرين عام مازالت تعريباته مستخدمة وهو الاستاذ عوض الغامدي احد اعضاء سوالف سوفت قام بابتكار الصندوق السحري الخاص بتنسيق الكتابة للمنتديات ومازال مستخدم الى اليوم بعد تطويره من اخرين ولكن يبقى صاحب السبق وهو الاخ والزميل علوي باعقيل الزميل والصديق رفيع العتيبي رحمه الله اول من برمج سكريبت مجلة عربية لادارة المحتوى مجلة المبرمج العربي عام 2003 ومازالت تستخدم على الرغم من وفاته من سنوات طويلة اسم السكريبت حاليا البوابة العربية الاستاذ خالد ممدوح برمج سكريبت منتدى وسبق الحديث عنه ولكن هو اول من برمج محرك عربي للبحث في الانترنت وحتى قبل محرك بحث جوجل للاسف الاخ خالد تعرض لهجوم غير مبرر حتى ترك فكرة تطوير المحرك وغيرهم الكثير ممن عرفتهم بشكل شخصي او زاملتهم في منتديات كانت منارة للعلم والابتكار وختام احزن لفقد هذه المنتديات كما حزنت لفقد العديد من الاخوة الذين اسهموا في تطوير المحتوى العربي وغالبيتهم استخدموا اسماء مستعارة واقول لهم كم من رجل مجهول في الارض معروف في السماء تحياتي واعتذر عن الاطالة

الأحبة الكرام،، المشرفين الأعزاء.. الأساتذة الفضلاء.. الحقيقة أن الموضوع آلمني لاسيما أني لست متخصص في البرمجة وإنما تعلمت على أيدي وأكتاف المنتديات كهذا المنتدى العامر ومنتدى الأكسس والوورد.. ومثل هذا مؤشر غير جيد.. وبالفعل نحن نرى في بعض المنتدى التي كان لها اسمها في العالم الافتراضي لم نعد نسمع لها صوتا.. بل وإني أذكر أن أكثرهم كان سببا في نشر الخير وبناء برامج لجهات خيرية لوجه الله وأعان ويسر الله على يديه ما لم يتيسر لشركات كبيرة.. فأفاد وأجاد.. أساتذتنا الكرام.. هذا من أبواب الخير التي تجري للمرء وهو لا يعلم.. فكم من إفادة بكود أو بفكرة فتحت آفاقًا.. ولولا الخصوصية لذكرت لكم أمثلة رائدة كان سببها هذا المنتدى وأفكار مشرفيه مما جعل منها بناء لبرامج خيرية في أماكن متعددة استفاد منها عدد كبير جدا جدا.. كلنا أمل مشرفينا الكرام أن نسعى جميعًا لإيجاد فكر جديد لمثل هذه المنتديات إما بفكرة وسائل التواصل الحديث وربطها بها.. أو بتطبيق وغير ذلك.. وأخيرًا لازلت مهما عشت أقر بفضل الله ثم بفضل هذه المنتدى علي وعلى غيري مما كان له كبير الأثر في حياتنا.. شكر الله لكم عطاءكم وبارك جهدكم ويسر لكم الخير حيث كان.. واعلموا أنما نحن بكم بعد الله، وكم من فكرة فتحت آفاقا،، وكم من فكرة سرت أجرًا ممتدًا..

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

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

:: السلام عليكم ورحمة الله وبركاته :: 🙂 يطيب لي أن أهديكم هذه الهدية البسيطة 🎁 :: مرسال الواتسأب :: وهو برنامج بسيط جدا لإرسال الرسائل عن طريق الواتسأب .. مع إمكانية إرسال المرفقات كذلك ( صور أو مستندات ) 🙂 وله واجهتين رئيسيتين : 1 - الرسائل الفردية 2 - الرسائل الموجهة لعدة أشخاص :: وهذه صور لواجهات البرنامج :: طبعا من الضروري تنصيب برنامج الواتسأب للكمبيوتر وتشغيله قبل تشغيل البرنامج 🙂 وبملاحظاتكم ودعواتكم دوما نرتقي 🙂 :: وأخيرا :: التحميل :: ☺️👌🏼 مرسال الواتسأب.accdb

أيوه .. هل المطلوب منى أن أضعه بملف ؟!!! أم هذا مطلوب منك انت.. وانت من تريد هذا فلا يمكن المساعدة بدون رفع الملف ووضع به الكود وشرح ما تريده بالضبط ؟!!!

وعليكم السلام ورحمة الله تعالى وبركاته ..تقضل اخي جرب 1_MH.xlsm

اختصار المطلوب : لا تكتب حرف "غ" في صفحة المسودة ، دع خلايا الغياب بدون أي بيانات.

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

السلام عليكم هل مازال لديك امكانية للدخول على بريد الياهو المسجل بالحساب الاصلي ؟ ارسلت لك رسالة على الخاص

وعليكم السلام-ارفع من فضلك الملف بسرعة ونبهنا كثير جداً على هذا الأمر .. لابد من رفع ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة وذلك تجنباً لإهدار وقت الأساتذة .لأنه لا يمكن العمل على التخمين ؟!!!

وعليكم السلام وسلمكم الله. لا يمكنك التعامل مع الجداول كما الورق ، فالخلايا/الخانات الرقمية لا يمكن أن تستخدم فيها حروفا. أرى أن تترك الخلايا "بيضاء" خالية/فاضية بدون أي بيانات وليس صفرا. هذا للمسودة ، وإذا أردت أن أضع لك حرف غ في صفحة القائمة المطلوبة فيمكنني إضافتها على الشفرة/الكود.

السلام عليكم و رحمة الله استخدم المعادلة التالية =SUM(E2;E5;E8)/SUM(COUNTIF(INDIRECT({"E2";"E5";"E8"});">0"))

زادك الله علما

استاذنا الفاضل موسى ، جزاك الله كل خير ، ونفع الله بعلمكم وزادكم من فضله .🙏 عمل رائع جداً ومجهود رااائع 😍 تم التجربة على ويندوز 11 (64bit)، اوفيس 2019 (64bit) وشغال تمام .😍👍 لكن النموذج يرسل الرسائل متلاصقة ويتجاهل الانتر الموجود في الاكسس، هل يمكن حل هذه الاشكالية؟ ايضاً اذا كان بالامكانية اضافة التعابير Emojis عبر النموذج في الاكسس . شكرا جزيلا استاذنا 🌹

يمكنك الاستفادة من هذا الموضوع

وعليكم السلام ورحمة الله وبركاته كيف حالك اخى هانى علم علامه صح على unblock

الله عليك انت ياابوشادى وجزاك الله خيرا ارجو من الاخ حسين @حسين العربى او احد المشرفين تعديل افضل اجابه لدكتورنا العزيز محمد فهو من قام بالاجابه ولم اقم بفعل شىء بالتوفيق

سلمت يداك استاذي @Moosak وزادك الله علما ونفع بك اخوانك والمسلمين وهذا ما كنا نبحث عنه وجربت على ويندوز 10 64 بت وشغال تمام لاكن احيانا يرسل للرقم الثالث ثم يتجاوز الرابع برسالة فقط بدون ارسال المرفق وغيرت اعدادات sleep وضبط معي اذا كان حجم المرفق صغير اما اذا كان حجم المرفق كبير فان "تم ارسال الرسالة للكل" تظهر قبل اكمال ارسال المرفقات لبقية الارقام

جزاك الله خيرا واخيراً حل للموضوع دا تسلما ايدك ووفقك الله دائماً .

﴿كُلُّ مَن عَلَيها فانٍ۝وَيَبقى وَجهُ رَبِّكَ ذُو الجَلالِ وَالإِكرامِ﴾ [الرحمن: ٢٦-٢٧]

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

أخى وأستاذى الكريم مبرمج متقاعد لما كل هذا القلق وليس هناك ما يدعى لكل هذا ان شاء الله منتدانا بخير وسيظل بكم قائم وبكل جهود القائمين عليه ان شاء الله

السلام عليكم سؤالي للمشرف الفاضل الذي قام بتعديل مشاركتي السابقة وحذف فقره منها كانت الفقرة ان نظام الاشراف في بعض المنتديات العربية يدار بعقلية عريف الصف هذه الفقرة ليس فيها تطاول على شخص معين او موقع معين وهي رأي شخصي وحذفها من المشاركة يدل على احتمالية صحة ما جاء فيها مرحبا باخي واستاذي ابو احمد مع ذلك لم يسلم الموضوع من مقص الرقيب اخيرا سوف اضع امثله لمنتديات كبيرة متخصصة تم اغلاقها ولن اشير الى اسم اي منها اكبر منتدى عربي للبرامج وله السبق في تعريب العديد من البرامج انتهى بوفاة مؤسسه رحمه الله تم اغلاق الموقع لفترة ثم اعيد ولكن بعد فوات الاوان منتدى كبير متخصص في تطوير المنتديات تم اغلاقة بسبب القوانين الصارمة والتي وصلت الى حد محاربة اصحاب الخبرة وايقاف عضوية العديد منهم بسبب خلاف مع احد المشرفين مما دفع الاخرين للابتعاد عن الموقع اكبر موقع عربي في عمل هاكات المنتديات ويضم افضل خبراء php العرب ومن هذا الموقع تم اصدار اول مجلة عربية بلغة php * تنافس مجلة Nuke ومن هذا الموقع تم عمل اول منتدى عربي ** ينافس منتدى vb قرر مالك الموقع تحويله الى موقع اخباري ! منتدى عربي كبير عدد الاعضاء بحدود مليون ونصف اختلف مؤسسي الموقع وبدلا من النقاش ومحاولة تقريب وجهات النظر قام احدهم بتدمير قاعدة البيانات هذه الامثلة كنت شاهد على احداثها وماخفي ربما يكون اكبر من ذلك ----------------------------- * مجلة المبرمج العربي تمت برمجتها بواسطة الاخ والصديق رفيع العتيبي رحمه الله ** منتديات في بي زوم برمجة الاستاذ خالد ممدوح

أحسنت ، قلت ما لا نستطيع قوله. وما لم تقله ربما أكثر وأكبر.

الكوود المرتبط بزر الطباعة 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

أخمن أنك قد بدلت في صفحة المسودة بحذف سطور أو أعمدة ، على كل لا يمكن التعديل بدون إرفاق الملف نفسه.

لا تعمل

السلام عليكم ورحمة الله وبركاته القلب يعتصر حزنا وانا اكتب لكم ... اغلاق منتدى شقيق ... منتديات الاكسس والوورد ....