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

Private Sub CommandButton1_Click() Dim ctrl As Control, cnt As Long For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then If IsNumeric(ctrl.Value) Then cnt = cnt + 1 End If Next ctrl MsgBox "TextBoxes With Numbers = " & cnt End Sub

بسم الله الرحمن الرحيم تطرق الكثير من المبرمجين إلى موضوع التفقيط وهو تحويل الأرقام إلى كلمات عربية ولكني كمعلم لمادة اللغة العربية لم أجد من هذه الدوال ما يتوافق مع قواعد اللغة العربية قاعدة كتابة الأعداد العربية بطريقة مضبوطة وصحيحة وتجد في هذا الرابط شرح مبسط للعدد وتمييزه http://www.reefnet.g.../AdadMadoud.htm وبفضل الله قمت ببرمجة دالة تقوم بتحويل الرقم إلى كلمات عربية مضبوطة تماماً وموافقة لجميع قواعد كتابة العدد في اللغة العربية تجدها هنا https://officena.net/team/mas/tafkeet وتم برمجة هذه الصفحة بلغة php وهذا الإصدار الجديد يعتمد فقط علي جافاسكريبت https://www.mr-mas.com/p/tafqeet.html وإذا لاقى الموضوع قبولا وإعجابا فسوف أعرض عليكم الكود الخاص بهذه الدالة أخوكم محمد صالح مبرمج بأكثر من لغة برمجة ومصمم ومطور مواقع

السلام عليكم ورحمة الله تعالى وبركاته يسأل البعض عن عدم حفظ البيانات الإ بإستكمال الحقول المطلوبة يمكن ذلك من خلال الفكرة الاتية ولكن بشرط اسم العنصر المطلوب ( الاجبارى) يجب وضع الرمز * فى الـ Tag الخاصة به كما بالصورة الاتية لاننى وضعت الاكواد فى الموديول تعتمد عليها والان الاكواد داخل الموديول 'RequiredData Function RequiredData(ByVal frm As Form) On Error Resume Next Dim ctl As Control Dim err As Integer For Each ctl In frm.Controls Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox, acOptionButton, acOptionGroup: 'If ctl.StatusBarText = "*" Then If ctl.Tag = "*" Then If IsNull(ctl) Or ctl = "" Or ctl = Null Then ctl.BackColor = 15531489 ctl.SetFocus err = err + 1: MsgBox "Please fill in the " & ctl.Controls(0).Caption: Exit Function Exit For Exit Function Else ctl.BackColor = 16777215 End If End If End Select Set ctl = Nothing Next ctl End Function ويتم استدعاء الكود من خلال Call RequiredData(Me) اترككم مع الاستمتاع بالتجربـة وفى انتظار ارائكم Required data (2).mdb

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته هذا برنامج رسم قطاعات الترع من بيانات رفع المساحي رسم قطاعات الترع 1.rar

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

الكود ينفذ المطلوب حذف الصف كاملا EntireRow.Delete لخلايا العمود c من الصف الأول إلى آخر صف مكتوب فيه Cells(Rows.Count, 3).End(3).Row بشرط أن تكون الخلايا فارغة SpecialCells(4) بالتوفيق

اعتقد لا ما ينفع

طيب علشان لو حابب تنقل التعدل لقاعدتك انت هذا الروتين الذى تم اضافته الى الموديول والذى ينشئ مسار للصورة تبعا للرقم الشخصى Public Function ImgPath(ByVal intProNo As Integer) ImgPath = CurrentProject.Path & "\Library Files" & "\Pictures\" & intProNo & "\" & Dir(CurrentProject.Path & "\Library Files" & "\Pictures\" & intProNo & "\") End Function وفى مصدر بيانات النموذج والجدول كذلك تم عمل استعلام واضافة الجزء الذى يستدعى الروتين كالاتى ImgPath([PersonalNumber]) وقمت بعمل تسمية لهذا الحقل فى الاستعلام ليكون الحقل باسم Pic فيكون السطر السابق من الكود بالشكل Pic : ImgPath([PersonalNumber]) وفى كل من النموذج , والتقرير نجعل عنصر التحكم فى الصورة يساوى الحقل Pic

شكرا للجميع تم التوصل الى المطلوب وهو Dim cnt As Long If IsNumeric(Me.TextBox11.Value) Then cnt = cnt + 1 If IsNumeric(Me.TextBox13.Value) Then cnt = cnt + 1 If IsNumeric(Me.TextBox15.Value) Then cnt = cnt + 1 If IsNumeric(Me.TextBox17.Value) Then cnt = cnt + 1 Me.textbox20.Value = cnt

شكرا جزيلا @أستاذ محمد صالح , المعادله ممتازه ووفررت على وقت كبير , وارجوا من حضراتكم لو امكن شرح المعادله او اى رابط على اليوتيوب لها

جميعا بإذن الله الأمر الثاني بسيط جدا ولا يحتاج لمحاولات كثيرة فقط يحتاج لفهم الشرطين وحذف أحدهما بالتوفيق

@أ / محمد صالح شكراً جزيلاً لك على مرورك العطر وسرعة الإجابة ساجرب الكود وأخبرك بالنتيجة جزاك الله خير الجزاء

وعليكم السلام وكيف تنتظر المساعدة من احد بدون رفع ملف مدعوم بشرح كافى عن المطلوب ؟!!!

يمكنك وضع هذه المعادلة في الخلية E8 لجلب اسم المورد =IFERROR(INDEX(A:A,MATCH($D8,$B:$B,0)),"") مع سحب المعادلة لأسفل بالتوفيق

وعليكم السلام ورحمة الله وبركاته استبدل هذه الجمله ThisWorkbook.Path & "\" الى "E:\"

الرجاء ضع الكود في <> كما موجود في اعدادات الكتابة والتنسيق لديك غير مجرب . مجرد محاولة كما ترى انشا مجلد في اي محرك تريده ثم قم بنسخ امتداده وضعه في الكود Private Sub CommandButton3_Click() Const csPath As String = "C:\Test\" If TextBox2.Value = "" Then MsgBox "ادخل اسم الصورة اولا": Exit Sub Var = TextBox2.Text مكان حفظ الصور ' SavePicture Image1.Picture, csPath & Var & ".jpg" MsgBox "تم حفظ الصورة بنجاح مع تحيات مجدى يونس", vbInformation End Sub

حسب فهمي للمطلوب أنك تريد تجميع نفس الخلية من جميع الشيتات لذا يمكن استعمال نفس تصميم الشيتات في شيت row مرفق ملفك وبه المعادلة الطبيعية في الجزء العلوي وكذلك دالة معرفة vba اسمها sumall في الجزء السفلي ودالة أخرى لصناعة المعادلة العادية بالكود بالتوفيق جمع الخلية من جميع الشيتات.xlsb

Sub Test() Const rAddress As String = "A2:J10" Dim ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("ROW") sh.Cells(1).CurrentRegion.Offset(1).ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> sh.Name Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 Set r = ws.Range(rAddress) sh.Range("A" & m).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value End If Next ws Application.ScreenUpdating = True End Sub

تفضل أخي الكود بالمرفقات وفقنا الله جميعا لكل خير mas_ar_n2t_utf.rar

Sub DeleteBlanks() Dim i As Integer Dim LR As Integer LR = ActiveSheet.UsedRange.Rows.Count For i = 2 To LR If Cells(i, 3) = "" Then Rows(i).Delete Next End Sub

وهذا هو الشكل الجديد للصفحة بعد استعمال الأجاكس واستدعاء الدالة عند كل تغيير في مكونات النموذج https://officena.net/team/mas/tafkeet/ وفقنا الله وإياكم لكل ما يحب ويرضى

فيها إيه (مصر بعد الثورة) فيها إيه لو كل مَن بيطبّل للزعيم ساب طبلته وقعد يخلّص شغلته مسكين زعيمنا اللي يحب الناس تقول عاش حضرته لو مرة دام الكرسي لحد كان دام عليه وفيها إيه لو كل واحد منّنا عاش يوم نضيف عاش يوم نضيف اسماً وفعلاً لو كفيف مش بس اسمه يكون نضيف ولا بس شكله يكون نضيف دا كل حتة ف مصرنا محتاجة منّا جهدنا نرفعها بيه وفيها إيه لو كل مسئول منّنا حس إنه مسئول عنّنا وسهر بيحمل همّنا همّه يزوّد دخلنا لجل ما يحبه الجميع ويكونوله ف يوم شفيع يطلبوا من ربنا ارضى يا ربي عليه وفيها إيه لو كل طالب ف المدارس شاف زميله أخ لِيه مش خصم ليه ليه يضربه؟! ليه عايزه دايما تحت منّه ويتبعه؟! لو ضعيف ميعرّفه يتعاون الاتنين وياخدو من إديه وفيها إيه لو كل ماشي ف الطريق بقة للإشارة محترم وجنب منّه أخوه وأخته أبوه وابنه فيلتزم هتقلّ حوادثنا الكتيرة هنبني أعلى م الهرم مش محتاجين جندي مرور تدفع إذا عدّيت عليه وفيها إيه لو يوم بتقضي مصلحة من مصلحة من غير ما تدفع حتى لو سموه تبرُّع ميجيش صاحبنا يقول يا سيد فوت علينا بكرة لسة ناقصة ختم النسر مش بالأكلا شيه وفيها إيه لو يوم بتتدخل قسم شرطة يقوموا ليك والظابط ابن الناس يكون قلبه عليك شغّل عساكره لخدمتك ومبعش يومها قضيتك والحق عاد ..... يكفيك تقول مشكور يا بيه وفيها إيه لو كل رواتبنا ف مصر اتعدّلت اتوحّدت مش ناس بتاخد بالألافات عايزين تزيد وناس بتاخد بالملايين من غير حساب بقة له رصيد وناس بتاخد بالملاليم ما شافتش عيد ويعيشوا ليه وفيها إيه أستاذنا اللي بيبني عقول ميكونش ليه زي البترول ولا وزارة الاتصالات ولا الرياضة والإعلام رغم ان كل الناس ف نهضتها كانت بدايتها من التعليم عايزينها تعلى وتبقى أعلى دولة ف العالم دا كله صلّحوا التعليم هتلقوا كل حاجة بقت تمام وتعظيم سلام لكل اللي هيبنيها من العامل لحد البيه وفيها إيه لو يوم نلاقي رئيسنا بيمشي ف الشارع على رجليه من غير حرس من غير مواكب أو جرس يرعى حبايبه المحتاجين الكل لما يشوفه هيبوسه ويسلّم عليه وفيها إيه جوايا لسة حاجات كتير عايزين نغيرها سوا كل اللي بيشوف الفساد عنده الدوا اصرخ وقول لأ واشتكي هتلاقي ميت مليون شَريف واقفين معاك ضد الفساد لو هتلاقيه وفيها إيه وفي البداية أطلب من الإخوة التعليق الجاد والتعبير عن كل سلبية يرونها لتكون هذه القصيدة للشعب المصري كله أخوكم

كل عام أنتم بخير يا أخي الكريم أبو أحمد عذراً لانقاطعي عن هذا الصرح التعليمي الكبير ؛ نظرا لتعطل النت لديّ فمن ايام الثورة المصرية إلى قبل العيد بأسبوع لم يكن عندي خط نت والحمد لله تم التوصيل وسيتم بإذن الله التواصل مع الأحباب

إن شاء الله مصر تذهب إلى الأفضل بإذن الله طالما بدأنا الطريق فاللهم وفقنا

شكرا لتواصلك أخي الكريم ومبروك الترقية ولكن يبدو أنك لم تقرأ ملف التعليمات جيدا 000

شكرا لك أخي الكريم جعلني الله عند حسن ظنكم جميعاً للعلم جاري تحويلها لكود vba للاستفادة منها في الأكسس والإكسل وغيرها من برامج ميكروسوفت

تم الرد على مثل هذا الموضوع أخي الكريم يمكنك استعمال البحث

أخي الكريم يمكنك استعمال الدالة trunc وهذه طريقتها =TRUNC((A7/1100)*100,2)