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

هذه ابسط طريقة .... طباعة.accdb

Dim x As Integer x = DCount("*", "tbl_2") If x > 30 Then MsgBox "عدد السجلات اكبر من 30", , "تحذير" End If او If Me.RecordsetClone.recordcount > 30 Then MsgBox "عدد السجلات اكبر من 30", , "تحذير" Else End If اختر اي من الطريقتين سبقتي استاذ احمد 🌹

وعليكم السلام اخى ازهر اتفضل جرب الكود التالى Private Sub Form_Current() If Me.RecordsetClone.RecordCount >= 30 Then MsgBox "ضع رسالتك كما تريد " End Sub بالتوفيق

ان شاء الله ما تحتاج مو عشان تغلبني ... لا .لا .... لان احتياجك يعني وقعت في مشكلة ..... والله يكفينا شر المشاكل ......

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

السلام عليكم ورحمة الله اليك الملف بعد اضافة بعض البيانات لعام 2022 للتجربة Sub GteData() Dim ws As Worksheet, Sh As Worksheet Dim Arr(), Temp() Dim y As Integer, m As Integer Dim yy As Integer, mm As Integer Dim i As Long, j As Long, p As Long Set ws = Sheets("تقرير السنين") Set Sh = Sheets("محمود") ws.Range("A9:E" & ws.Range("B" & Rows.Count).End(3).Row).ClearContents m = Month("01/" & ws.Range("A3").Value) y = ws.Range("B3").Value Arr = Sh.Range("A9:E" & Sh.Range("B" & Rows.Count).End(3).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) yy = Year(Arr(i, 2)) mm = Month(Arr(i, 2)) If yy = y And mm = m Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A9").Resize(p, UBound(Temp, 2)).Value = Temp End Sub Naser.xlsm

هذه صورة من برنامجي ، اكسس 2010 ، والمكتبة اصبحت Miscrosoft Access xx Object Library : . وانا لا احب ان استعمل المكتبة ، لأنها لها علاقة بنسخة الاكسس ، واختيار المكتبة تسمى بـالربط المسبق Early Binding (مع ان هذه الطريقة اسرع ، ويساعدك الاكسس في اعطائك المتغيرات المتوفرة للأمر عند عمل: مسافة او نقطة او فتح قوس)، فإذا تمت البرمجة على النسخة الاقدم ، وتم استعمال البرنامج على النسخة الاحدث ، فيقوم البرنامج تلقائيا بتغيير المكتبة للأحدث ، واما اذا تمت البرمجة على النسخة الاحدث ، وتم استعمال البرنامج على النسخة الاقدم ، فلن يعمل البرنامج ، وسيعطيك خطأ !! ولتفادي هذه المشكلة ، فيمكننا عمل ربط متأخر Late Binding بتعريف المتغير بـ Object ، هكذا : Dim FileDialog As Object With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Add "Pic Files", "*.jpg ; *.bmp" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then Open_a_File = .SelectedItems(1) End If End With جعفر

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

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

Dim x As Integer x = DCount("*", "tbl_img") If x > 30 Then If MsgBox("عدد السجلات اكثر من 30", vbYesNo, "تنبيه") = vbYes Then DoCmd.OpenForm "frm_1" Else DoCmd.CancelEvent End If End If

أحسنت استاذ سليم عمل ممتاز الكود يعمل بكل كفاءة ولا يوجد به اى مشكلة بالفعل وتم تجربته علي الهتاري كما أخبرك استاذنا الكبير سليم حاصبيا فالملف يعمل بكل كفاءة فإن كان هناك مشكلة لديك فمن عندك فربما تكون بالفعل نسخة الأوفيس عندك أقدم من 2010 كما اخبرك استاذنا الكريم فعليك بتحديث الأوفيس لديك وشكرا ... عليك وضع هذه المعادلة بداية من الخلية C2 سحباً للأسفل =LEN(B2)-LEN(SUBSTITUTE(B2,",",""))+1 Hitari.xlsm

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

في شيء في الحياة اسمه تجربة/تجارب ، في كثير من الاوقات تكون باهضة الثمن ، مو مبالغ فقط جعفر

اللهم آمين أجمعين ان شاء الله تسلم اخى و استاذى العزيز 💐

امين يارب ..... دائما وابداااااااااااااااا احفظ نسخ لبرامجك واياك استاذي الغالي احمد .... للاسف ليس مجاني .....

اذا كان ما فهمته صحيحاً هذا الكود (فقط اضغط الزر Run) Option Explicit Sub Creezy_sort() Dim CoL As Object Dim Lr%, i%, x% Dim arr Dim Ws As Worksheet Set Ws = Sheets("EN") With Ws .Range("E1").CurrentRegion.Offset(1).ClearContents Set CoL = CreateObject("System.Collections.sortedlist") Lr = .Cells(Rows.Count, 1).End(3).Row For i = 2 To Lr CoL.Add Len(.Cells(i, 1)) + i / 1000, .Cells(i, 1) & _ "*" & .Cells(i, 2) Next i x = 2 For i = 0 To CoL.Count - 1 .Cells(x, "E") = Split(CoL.GetByIndex(i), "*")(0) .Cells(x, "F") = Split(CoL.GetByIndex(i), "*")(1) arr = Split(Split(CoL.GetByIndex(i), "*")(1), ",") .Cells(x, "G") = UBound(arr) + 1 x = x + 1 Next End With Set Ws = Nothing: Set CoL = Nothing End Sub الملف مرفق Hitari.xlsm

اتفضل جرب New Microsoft Access Database (1).zip

استاذي الفاضل والعزيز / @ابا جودى استاذى الفاضل / شوف كده Test.accdb

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF($J$3="";"";SUMIF('كشف حساب العملاء'!$C$4:$C$344;$J$3;'كشف حساب العملاء'!$E$4:$E$344)-SUMIF('كشف حساب العملاء'!$C$4:$C$344; $J$3;'كشف حساب العملاء'!G4:G344))

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

أحسنت استاذ محمد بارك الله فيك عمل رائع جعله الله فى ميزان حسناتك ولكن من الأفضل طبعاً جعل البرنامج يعمل على النواتين سواء 32 أو 64 بت معاً فالبرنامج يعمل فقط على النواة 32 بت ... ولكم جزيل الشكر

ممكن مرفق يمكن افهم معلش فهمى على اد حالى ومش قادر افهمك

نتاج التعلم والاستفادة من اساتذة المنتدى الافاضل ( جامعة أوفيسنا ) والذين يستحقون مقاعد التدريس بأكبر الجامعات يسعدني إصدار تحديث لبرنامج مكافأة امتحانات النقل طبقا لآخر تعليمات صدرت من الوزارة للمديريات ويتميز هذا الإصدار إمكانية ادخال البيانات يدويا باللصق والقوائم المنسدلة أو عن طريق شاشة ادخال البرنامج بإمكانية التعديل في المستقطعات ونسب خصمها وذلك في صفحة نسب المستقطع أو ايقاف خصمها بوضع رقم (0) في خانة النسبة وكذلك يقوم البرنامج بحساب عدد الايام المستحقة للمحالين للمعاشات أو الوفاة بادخال تاريخ انتهاء الخدمة بعد تحديد ذلك من خلال قائمة منسدلة تحوى (قانون 155 ـ قانون 81 ـ معاشات ) حساب المكافاة لحظة ادخال بيانات الموظف ويمكن الاستعلام عن اى اسم من خلال صفحة الاستعلام مخرجات البرنامج كشوف مكافأة الموظفين ـ كشف اجمالى ـ مرايا التجمي ـ مسيرات المستقطع بالنسبة لخصم مستشفى المعلمين المطبق بمحافظة المنيا فقط يمكن ايقاف خصمه في باقى المحافظات عن طريق اختيار (لا تخصم ) من القائمة المنسدلة سواء كان الادخال يدويا أو بشاشة الادخال وكذلك يمكن عن طريق وضع (0) في صفحة نسب المستقطع أمام خصم المستشفى أسم المستخدم محمد فتحى كلمة المرور 1970 وكلمة محرر الاكواد 6101970 أرجو مراجعة البرنامج من اساتذتى الافاضل والعاملين بالتربية والتعليم بمصر 1578014707_2021.xlsb

تسلم اخى ومعلمى العزيز تنويه بسيط :- ان شاء الله تكتب ان شاء الله وليس انشاء الله والله اعلى واعلم ولعلها من سرعه الكتابه احبكم فالله

جعلكم الله واياي من الذين يسارعون في الخيرات جزيل الشكر

والاجمل منه اخي جعفر قوله سبحانه و تعالي : " قُلْ لا أَمْلِكُ لِنَفْسِي نَفْعًا وَلا ضَرًّا إِلا مَا شَاءَ اللَّهُ وَلَوْ كُنْتُ أَعْلَمُ الْغَيْبَ لاسْتَكْثَرْتُ مِنَ الْخَيْرِ وَمَا مَسَّنِيَ السُّوءُ ِ " صدق الله العظيم

رحم الله الجواهري تَجري على رَسْلِها الدنيا ويَتْبَعُها رأْيٌ بتعليـلِ مَجْراهـا ومُعْتَقَـدُ أَعْيَا الفلاسفةَ الأحرارَ جَهْلُهمُ ماذا يُخَبِّـي لهم في دَفَّتَيْـهِ غَـدُ طالَ التَّمَحُّلُ واعتاصتْ حُلولُهمُ ولا تَزالُ على ما كانتِ العُقَـدُ

على الجرح تماما 🩸

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

الدوران عن طريق الجدول او الاستعلام افضل من النموذج .... والله اعلم

السلام عليكم 🙂 اما انا فاستخدم البرنامج المجاني: وهذا ما تم اصلاحه: جعفر

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

لا أعرف ما المشكلة عندك (ربما اصدار الااوفيس قديم) عندي يعمل بشكل جيد (الصورة)

بعد اذن الاستاذ إبراهيم هذا الكود Option Explicit Sub My_Repport() Dim Mh As Range, Single_Cel As Range Dim Y%, M%, i%, x% Dim My_Months(), Arr_Year() x = 6 Takrir.Range("A5").CurrentRegion.Offset(1).ClearContents Arr_Year = Array(2020, 2021, 2022, 2023, 2024, 2025) My_Months = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") If IsError(Application.Match( _ Takrir.Range("B3"), Arr_Year, 0)) Then Exit Sub If IsError(Application.Match( _ Takrir.Range("A3"), My_Months, 0)) Then Exit Sub Set Mh = Mahmoud.Range("A5").CurrentRegion.Columns(2) Y = Takrir.Range("B3") M = Application.Match(Takrir.Range("A3"), My_Months, 0) For Each Single_Cel In Mh.Cells If IsDate(Single_Cel) And Month(Single_Cel) = M _ And Year(Single_Cel) = Y Then Takrir.Range("A" & x).Resize(, 5).Value = _ Single_Cel.Offset(, -1).Resize(, 5).Value x = x + 1 End If Next Single_Cel End Sub الملف مرفق Naser_data.xlsm

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

شكرا استاذي علي هذا المجهود الرائع تم عمل اللازم بالظبط شكرا جدا

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

اتفضل 1373.حفظpdf.accdb

انضم معكم اخوانى لتقبيل راس استاذى وآخى فى الله جعفر واخى وأستاذى ابو خليل احترامى

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

اعمل موضوع جديد ، وضع فيه رابط/الاشارة الى هذا الموضوع ، ثم ارجع الى هذا الموضوع ، وضع فيه رابط/الاشارة الى الموضوع الجديد ، بهذه الطريقة الجميع يعرف 🙂 جعفر

اخي قم بتغيير اللغة للإعدادات الاقليمية كما في الصورة ادناه و النتجية

ابحث عن هذا With imsg With imsg .to = StudentEmaile .from = DLookup("settingsUsername", "settings", "settingNO=1") .Subject = "ÔåÇÏÉ" .HTMLBody = Mymsg .AddAttachment (MyAttachment) Set .Configuration = iconf .Send End With واستبدله بهذا ..... With imsg .BodyPart.Charset = "UTF-8" .to = StudentEmaile .from = DLookup("settingsUsername", "settings", "settingNO=1") .Subject = "ÔåÇÏÉ" .HTMLBody = Mymsg .AddAttachment (MyAttachment) Set .Configuration = iconf .Send End With تم اضافة هذا السطر .BodyPart.Charset = "UTF-8"

تفضل هذا التعديل تم تعديل الرسالة الى تنسيق HTML ة تم اضافة اللغة العربية للشفرة email.1.zip

ادخل على حسابك من خلال الرابط التالي وفعل التطبيقات الاقل امانا ويعمل معك https://www.google.com/settings/security/lesssecureapps

جرب هذا الملف 1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً) مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات) 2- من المفروض اضافة القليل من البيانات في الأوراق العمل ولا تتكل على من يريد المساعدة للقيام بذلك 3- تم وضع بعض المعادلات التي تساعد في ادراج النتائج (دون ظهور الأصفار) 4- الصف رقم 6 في الاوراق Bay و Inport يجب ان يبقى فارغاً الكود Option Explicit Sub From_Sheets_To_MaG() Dim Inp As Worksheet, Bay As Worksheet Dim Mag As Worksheet Dim Sh As Worksheet Dim L_Mag%, Max_ro%, col%, k%, ro% Dim Fnd As Range, Wat As Range Dim Old_val Set Inp = Sheets("Inport") Set Bay = Sheets("Bay") Set Mag = Sheets("Magazine") L_Mag = Mag.Cells(Rows.Count, 1).End(3).Row Set Fnd = Mag.Range("A1:A" & L_Mag) If Not (ActiveSheet.Name = "Inport" Or _ ActiveSheet.Name = "Bay") Then Exit Sub Set Sh = ActiveSheet Select Case Sh.Name Case "Bay": col = 6 Case "Inport": col = 5 Case Else: Exit Sub End Select Max_ro = Application.Max(Sh.Range("B6:B68")) + 6 For k = 7 To Max_ro Set Wat = Fnd.Find(Sh.Range("E" & k), lookat:=1) If Not Wat Is Nothing Then ro = Wat.Row Old_val = Val(Mag.Cells(ro, 3)) Mag.Cells(ro, 7) = Old_val Mag.Cells(ro, col) = Val(Sh.Range("H" & k)) Mag.Cells(ro, 3) = _ Old_val + Val(Mag.Cells(ro, 5)) - Val(Mag.Cells(ro, 6)) End If Next End Sub الملف مرفق Hasan_B.xlsm

عليكم السلام. Sub sendOutlookEmail() Dim oApp As Outlook.Application Dim oMail As MailItem Set oApp = CreateObject("Outlook.application") Set oMail = oApp.CreateItem(olMailItem) oMail.Body = "Body of the email" oMail.Subject = "Test Subject" oMail.To = "Someone@somewhere.com" oMail.Send Set oMail = Nothing Set oApp = Nothing End Sub