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

اذا كنت تريده بالماكرو جرب هذا الشيء Option Explicit Sub Get_Date() Dim x As Long, y As Long, t As Long, Interval Application.ScreenUpdating = False With Sheets("Sheet1") If .Range("B1").CurrentRegion.Rows.Count > 1 Then _ .Range("B1").CurrentRegion.Offset(1).Clear '+++++++++++++++++++++++++++++++++++++++++++ .Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = " Click Please" '+++++++++++++++++++++++++++++++++++++++ If Not IsDate(.Range("E1")) Or _ Not IsDate(.Range("G1")) Then Application.ScreenUpdating = True: Exit Sub x = Application.Min(.Range("E1"), Range("G1")) y = Application.Max(.Range("E1"), Range("G1")) Interval = "Row(" & x & ":" & y & ")" .Range("B2").Resize(y - x + 1) = Evaluate(Interval) .Range("B1").CurrentRegion.NumberFormat = "[$-ar-lb]ddd d mmm yyyy" 'The following Lines of code between the (+) Sign Are Optional _ You can Stop it by typing an "," Before each '+++++++++++++++++++++++++++++++++++++++++++++++ t = .Range("B1").CurrentRegion.CurrentRegion.Rows.Count With .Range("B1").CurrentRegion.Offset(1).Resize(t - 1) .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Interior.ColorIndex = 19 End With .Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = y - x + 1 & " Days at All" '+++++++++++++++++++++++++++++++++++++++++++ .Cells(1, 1).Select End With Application.ScreenUpdating = True End Sub الملف مرفق List Interval_Of Days.xlsm

حياك الله أخي @خالد عبد الغفار كل عام وانت في صحة وسلامة في النموذج هناك مربع نص باسم countRec ..... انظر الصورة

جرب ووافينا بالنتيجة khaled.rar

بالتوفيق ..... حياك الله ..... امين وياك

مشاركة مع الاساتذة .... مثال (7).accdb

مشاركه لاخى @عبدالقدوس48 جزاه الله خيرا لعل هذا ما تريد مثال.accdb

الإخوة الأعضاء الكرام : في المرفق دالة تقريب بسيطة للأرقام يمكن استخدامها لتقريب أي رقم إلى أقرب عدد صحيح أو إلى أقرب رقم من مضاعفات الوسيطة (numApp) . إلى الأعلى أو إلى الأسفل حسب اخيارك. أرجو أن تفيدكم. قاعدة بيانات1.rar

تفضل اخي العزيز ارجو ان يكون طلبك Root650.rar

جرب .. وهي فكره سريعه يمكن ان تفي بالغرض او عد وسنعود تحياتي Database10.accdb

جزاكم الله خيراً أستاذنا الكريم @سليم حاصبيا على هذه الأكواد الرائعة

وعليكم السلام والرحمة تفضل اخي العزيز ملاحظة: المشكلة ليس في دالة التفقيط وانما في دالة Fix كذلك تم تعديل كتابة الرقم اذا كان الناتج عدد صحيح القصد انه يقرا فقط خمسة طن بدل فقط خمسة طن وصفر Root500.rar

السلام عليكم امتداداً لتطويرات برنامج الخليل المحاسبي يسرني أهدي لكم الإصدار الثاني مع تعديلات وإضافات جميلة كما أشكر أستاذي الفاضل @sandanet لقد استفدت من طريقته في الحماية حسب مشاركته القيمة : اترك لكم البرنامج . وآملاً أن اتلقى ملاحظاتكم القيمة بعد استخدام البرنامج . تقبلوا فائق المحبة والتقدير BuySal20_V14.accdb BuySal20_V14.accdb.mdb.zip

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

حسب ما فهمت منك .... تفضل تشابه.accdb

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

شكراً اخوية احمد الفلاحجي و اخوية ابو البشر ممنون.

تمام التمام استانا / kanory ضبط معايا بعد ما نسخت مربع النص فى النموذج فرج الله همك واعطاك كل ما تتمنى وكل عام وانتم بخير استاذنا

ابحث عن المكتبة المشار اليها

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

بعد اذن أستاذ احمد تفضل اخي هذا بالكود بعد كتابة الارقام اضغط على ايقونة العدسة وسيتم جلب البيانات Sub EtaEng() Dim idnum As Variant, b As Object, i As Double Sheet2.Activate idnum = Left(Range("D7").Value, 4) Set b = Sheet1.Columns("b").Find(idnum, lookat:=xlPart, LookIn:=xlValues) If Not b Is Nothing Then 'exists i = b.Row Range("D10").Value = Sheet1.Cells(i, 3) Range("D12").Value = Sheet1.Cells(i, 2) Range("D14").Value = Sheet1.Cells(i, 4) Range("D16").Value = Sheet1.Cells(i, 5) Range("H10").Value = Sheet1.Cells(i, 6) Range("H12").Value = Sheet1.Cells(i, 7) Range("H14").Value = Sheet1.Cells(i, 8) Range("H16").Value = Sheet1.Cells(i, 9) Else MsgBox "هذا الرقم غير موجود", vbExclamation End If End Sub ملاحظة : يمكنك تغيير عدد الارقام كما تشاء من خلال هذا السطر وهو مصمم لاربعة ارقام ويجب ان تكتب الارقام من اليسار الى اليمين كما ترى idnum = Left(Range("D7").Value, 4) كشف_المحتاجين_2.xlsm

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

تفضل Book150 code.xlsm

تكرم يا استاذ تمام ..

بسم الله اتفضل اخى @ازهر عبد العزيز ان شاء الله يكون تمام Elements.accdb

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

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

في البداية ، لا ، ولم يكن هناك اي مشكلة ، ولكن لاحقا اضطررنا ان نعمل IP خاص لشبكتنا ، حتى لا نسمح للمستخدمين الآخرين رؤية برامجنا ومجلداتنا واجهزتنا ، ولما عملنا الشبكة الاصغر ، ولم يكن هناك DHCP Router ليوزع الـ IP ، فعملنا IP ثابت (Static IP) 🙂 جعفر

وعليكم السلام تفضل استاذي العزيز ارجو ان يكون طلبك Root451.rar

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

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

هلا اخي جرب هذا المرفق مع بعض التعديلات..الفورم على اعدادت الادخال بالتوفيق Test3_UPDATED.accdb

بالخدمة استاذي العزيز والتوفيق ان شاء الله

بالخدمة استاذ حربي العنزي في استعلام QQMsIsdar يوجد حقل duration1 وضعت للمعادلة عيارة val

مثال New Microsoft Excel Worksheet_2.xlsm

في محرر الاكواد اضغط alt+ f11 ثم ادراج موديل جديد ثم لصق

تفضل Book150 code.xlsm

جرب هذا الكود Sub abdelfatta() Dim Ary As Variant Dim r As Long, c As Long Ary = Range("A4").CurrentRegion.Value2 With CreateObject("scripting.dictionary") For r = 1 To UBound(Ary) For c = 1 To UBound(Ary, 2) .Item(Ary(r, c)) = .Item(Ary(r, c)) + 1 Next c Next r Range("E4").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items)) End With End Sub الاكواد شغالة معي ملفك هو فيه مشكلة جرب تصميم ملف اخر

بارك الله فيك وزادك الله من فضله

مشاركه مع اخى واستاذى @kanory جزاه الله خيرا انظر للاستعلام q ان كان ما تريد ابنى نموذجك عليه تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق New Microsoft Access قاعدة بيانات (3)(1).accdb

وعليكم السلام-بارك الله فيك هدية بالطبع مقبولة جزاك الله كل خير

السلام عليكم ورحمة الله جرب المرفق لعل فيه ما تريد... إيجاد درس المراجعة.xlsx

بعد اذن استاذنا الكبير سليم تفضل اخي هذا بالكود Sub nn() Dim StartDate As Date Dim EndDate As Date Dim NoDays As Integer StartDate = Range("e1").Value EndDate = Range("g1").Value NoDays = EndDate - StartDate + 1 sheet1.Range("A1").CurrentRegion.Clear If StartDate > EndDate Then MsgBox "لا يمكن ان يكون تاريخ النهاية اقل من تاريخ البداية " Exit Sub End If Range("A1").Value = StartDate Range("A1").Resize(NoDays).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _ xlDay, Step:=1, Stop:=EndDate, Trend:=False End Sub كتابة الفترة اوتوماتيك.xls

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

اخي العزيز ممكن عمل ذلك عن طريق الاستعلام تفصل انشاء الله يكون المطلوب اخي هل الضغط علة زر الاعجاب بالاجابة صعب عليك؟؟ تحياتي اذا تمت الإجابه على السؤال فلا تنسى الضغط على ( أفضل إجابة ) اختبار-4.rar

السلام عليكم هلا انا اظهرت لك زر للتقرير في المرفق خسب طلبك الاول الطلب الثاني انتظرني ان شاء الله تحياتي اختبار.rar

السلام عليكم 🙂 الموضوع كان معقد اكثر مما كنت اعتقد ، وبدأت من جديد اكثر من مرة !! ولكنها خزية تضاف الى شيء اسمه تجربه 🙂 اساس العمل هو استعلام Crosstab ، سهل عمله ، ونتائجه مقبولة 🙂 . . . ولكن لأنك اصررت انك تريد طريقة الجدول ، فأكملنا المشوار من هنا ، بالاستفادة من هذا الاستعلام ، وتحويله الى استعلام إلحاقي ، ليلحق البيانات في الجدول Co_to_Row : . جعلت جميع اسماء الحقول بنفس الطريقة ، والاهم ، اني اضفت حقل الرقم التلقائي: . وتكون البيانات هكذا: . ثم يأتي دور هذا الزر الكبير ، ليقوم بتشغيل الوحدة النمطية ، والتي ستقوم بتعديل البيانات في الجدول . وهذه هي الوحدة النمطية اللتي تقوم بالعمل ، وحاولت ان اجزئها ، واضع الشرح فيها : Public Function ReArrang() '1 Dim rstS As DAO.Recordset Dim rstD As DAO.Recordset Dim RCs As Integer Dim i As Integer Dim N As Integer Dim Co As String Dim jo As String Dim arr_Co() As String Dim arr_jo() As String '2 'append the New data to the Table Co_to_Row DoCmd.SetWarnings False DoCmd.OpenQuery "qry_Append_Co_to_Row" DoCmd.SetWarnings True '3 'we have 8 Areas For N = 1 To 8 '4 'make the field names, based on the loop value Co = "Co" & N jo = "jo" & N '5 'get each set (fields CoX and joX) values Set rstS = CurrentDb.OpenRecordset("Select * From Co_to_Row Where " & Co & " IS NOT NULL") rstS.MoveLast: rstS.MoveFirst: RCs = rstS.RecordCount '6 ReDim arr_Co(RCs) ReDim arr_jo(RCs) '7 'fill the array For i = 1 To RCs '8 arr_Co(i) = rstS(Co) 'Co values arr_jo(i) = rstS(jo) 'jo values '9 'Remove this value from the previous Records rstS.Edit rstS(Co) = "" rstS(jo) = "" rstS.Update '10 rstS.MoveNext Next i '11 Set rstD = CurrentDb.OpenRecordset("Select * From Co_to_Row Order By Auto_ID") '12 For i = 1 To RCs '13 'add this value to fill all Records rstD.Edit rstD(Co) = arr_Co(i) rstD(jo) = arr_jo(i) rstD.Update rstD.MoveNext Next i Next N '14 'Delete the Empty Records DoCmd.OpenQuery "qry_Delete_Empty_Records" '15 rstS.Close: Set rstS = Nothing rstD.Close: Set rstD = Nothing MsgBox "Done" End Function . وهذا استعلام حذف السجلات الفارغة: . والنتيجة النهائية للجدول: . جعفر 1045.col_to_raw.mdb.zip