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

السلام عليكم و رحمة الله اليك شرح الكود المطلوب ارجو ان اكون قد وفقت Sub LastTest() '-------------------- Dim i As Long, ws As Worksheet, Rng As Range Dim C As Range, p As Integer, x Dim Shp As Shape, Nam As String Set ws = Sheets("Sheet2") Application.ScreenUpdating = False Range("AO5:BB100") = "" ' مسح النطاق الذى سوف يتم ارسال بيانات التلاميذ الضعاف Set Shp = ws.Shapes(Application.Caller) ' تعريف الشكل حسب العنوان المكتوب عليه Nam = Shp.TextEffect.Text ' الاسم المكتوب على الشكل ws.Range("AQ1") = " الطلاب الضعاف اقل من 65 % ل" & Nam ' عبارة تكتب عقب الضغط على اى زر حسب الشهر p = 4 ' لعد التلاميذ الضعاف بدلا من الصفر يعنى i = 5 ' اول صف سوف يتم العمل عليه Do While i <= 70 ' آخر صف سوف يتم العمل عليه حسب المرفق و يم تغييره بسهولة With ws Select Case Nam ' الاعمدة التى سوف يتم العمل عليها حسب اسم الشهر المكتوب على الزر Case "شهر 10" x = Array(1, 2, 3, 4, 5, 6, 7, 11, 15, 19, 23, 27, 31, 35) Case "شهر 11" x = Array(1, 2, 3, 4, 5, 6, 8, 12, 16, 20, 24, 28, 32, 36) Case "شهر 12" x = Array(1, 2, 3, 4, 5, 6, 9, 13, 17, 21, 25, 29, 33, 37) Case Else End Select For j = LBound(x) To UBound(x) ' عدد الاعمدة المطلوبة للعمل عليها و تكون مصفوفة Set Rng = .Cells(i, x(j)) ' التعريف بالنطاق و جعل كل صف على حدة كمصوفة مستقلة بذاتها For Each C In Rng ' كل خلية فى هذا النطاق y = .Cells(4, x(j)) * 0.65 ' شرط النجاح If .Cells(i, x(j)) < y Then ' اذا كان الشرط غير متوافر m = m + 1 ' عد مواد الرسوب اقل من 65% If m > 1 Then GoTo 88: ' تكفى مادة واحدة ليبدأ للعمل عليها p = p + 1 ' العد For a = 0 To 13 ' عدد الخلايا التى سيتم ترحيل البيانات اليها .Cells(p, a + 41) = .Cells(i, x(a)) ' ترحيل البيانات .Cells(p, 41) = p - 4 ' مسلسل للتلاميذ الضعاف Next End If Next Next End With 88: m = 0 i = i + 1 Loop End Sub

وعليكم السلام- باركود IDAutomationHC39M Idautomationhc39m.zip

هذه مجموعة من الخطوط يمكنك تحميلها وتثبيتها في ويندوز واستعمالها في الاكسل أو الاكسس أو اي برنامج من برامج ميكروسوفت Code 128 Code 39 UPC-E QR Postnet UPC/ EAN I2of5 Intelligent Mail بالتوفيق

يمكنك استعمال هذه المعادلة في الخلية G19 مع سحبها لأسفل =IF(D19="","",VLOOKUP($B$2,المقسطون!$B$27:$N$62,6,0)) بالتوفيق

يمكنك استخدام هذه المعادلة في الخلية C13 =MOD(SUM(C5:C12),1000) وهذه المعادلة في الخلية D13 =SUM(D5:D12,INT(SUM(C5:C12)/1000)) بالتوفيق

برنامج طباعة الاختبارات تعديل نهائي.rar

إن شاء الله تفيدك هذه النتائج https://www.officena.net/ib/search/?q=البحث بمجرد&quick=1&type=forums_topic&nodes=135&updated_after=any&sortby=relevancy&search_and_or=and بالتوفيق

أإذا كان فهمي للمطلوب صحيحا يمكنك وضع هذه المعادلة في الخلية C19 مع سحبها يسارا =LEN($B$19)-LEN(SUBSTITUTE($B$19,C18,"")) بالتوفيق

نعم اخي يمكنك دالك بتعطيل هدا الصف فقط f.UsedRange = f.UsedRange.Value رغم انني عند كتابة الكود لاحظت ان الفكرة ربما لم كانت على يوزرفورم سوف تكون مميزة (لانني دائما عند الاشتغال على اي ملف اطمح الى تقديم الافضل رغم عدم طلبه ) لهدا قررت بعدما طلبت مني التعديل بانشاءه ربما يساعدك على الاشتغال على الملف بشكل افضل مع البقاء على الكود الاول ليبقى لك اختيار ما يناسبك طبعا اليك شرح الكود الاول ربما تحتاج يوما الا تعديل شيء ما Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet ' رسالة تنبيه عند كتابة اسم غير موجود على المصنف arr(1) = "المرجوا التحقق من إسم ورقة العمل" ' رسالة بنجاح النسخ تتظمن اسماء الاوراق الجديدة arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") ' التحقق من اسم ورقة العمل المراد نسخها If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng ' تجاهل الفراغات اثناء التحديد If dico <> Empty Then Application.ScreenUpdating = False ' التحقق من وجود اسم الشيت مسبقا على المصنف If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet 'تسمية اوراق العمل f.Name = dico ' حدف الازرار f.DrawingObjects.Delete 'التحويل الى قيم ' f.UsedRange = f.UsedRange.Value ' تخزين اسماء الشيتات الجديدة For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub تفضل اخي في انتظارك بعد تجربة الملف وسوف نكون سعداء دائما بمساعدتك Create-Sheets_User.xlsb

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

@Foksh لك جزيل الشكر

DoCmd.Save Or DoCmd.RunCommand acCmdSaveRecord

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

@Foksh الف شكر فعلا أن تعلمني الصيد أفضل من أن تعطيني سمكة جزاك الله كل خير

تفضل أخي الكريم @Samer Alani ، فيديو يوضح لك لطريقة بشكل أفضل من مرفق حتى تتوضح لك الفكرة 20231119_184539.zip

اشكرك اخي FOKSH المشكله بدقة الشاشه ملظبطش الا لما عملت Custom scaling

اذا تم حل المشكلة اختاري افضل اجابه لغلق الموضوع

بسيطه جربي غيري السطر هذا DoCmd.OpenReport "Barcode", acViewReport فى زر الطباعة DoCmd.OpenReport "Barcode", acViewPreview او باى طريقه انتى حابها ^_^

هل هذا ما تريدين ؟ طبعا التعديلات كثيره اولا هذا الصب ما يقوم بالعمليات المهمه Sub SendDataTests() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String Dim tubeDict As Object Dim tubeValue As Variant Dim testValue As String Dim idValue As Long Dim barcodePrintValue As Boolean Dim sendValue As Boolean Set db = CurrentDb Set tubeDict = CreateObject("Scripting.Dictionary") strSQL = "SELECT tube, test, ID, barcode_print, send FROM TEMPTEST;" Set rs = db.OpenRecordset(strSQL) Do While Not rs.EOF tubeValue = rs!tube testValue = rs!test idValue = rs!ID barcodePrintValue = rs!barcode_print sendValue = rs!send If Not tubeDict.Exists(tubeValue) Then tubeDict(tubeValue) = testValue Else tubeDict(tubeValue) = tubeDict(tubeValue) & ", " & testValue End If rs.MoveNext Loop rs.Close Set rs = Nothing db.Close '--------------------------------------------------------------------------------------------- Set db = Nothing Set db = CurrentDb For Each tubeValue In tubeDict.Keys strSQL = "INSERT INTO TEMPTEST2 (tube, [test], ID, barcode_print, send) " & _ "VALUES ('" & tubeValue & "', '" & tubeDict(tubeValue) & "', " & idValue & ", " & barcodePrintValue & ", " & sendValue & ");" db.Execute strSQL Next tubeValue db.Close Set db = Nothing End Sub ,طبعا تم عمل جدولين لحفظ البيانات مؤقتا وهم جدول TEMPTEST وجدول TEMPTEST2 وتم عمل 3 استعلامات ( اثنين لتفريغ البيانات من الجدولين المؤقت والثالث لنقل البيانات التى سيتم معالجتها الى الجدول الاول والملف الذى فيه كل ما تم هنا طباعة باركود-1.rar

بارك فيك ولك استاذ محمد نعم هذا ما اردته تماما ... دمت بود عافية

يمكنك البحث في فيس بوس عن (كنترول رجب جاويش) برنامج جميل لصديق محترم

@أ / محمد صالح فعلا هو المطلوب ربنا يجازيك الجنه الف مليون شكر

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

هذا مثال بسيط Year_2023.accdb

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

جرب الملف ..... New Microsoft Access قاعدة بيانات.rar

وهذا شرح لرموز الإدخال من دورة المبدع منذر السفان 🙂 أنواع الرموز المستخدمة في أداة شكل الإدخال Input Mask.pdf

الاخ الحبيب "طاهر" الحماية في اكسل غير تامة و كلما ازداد الشخص خبرة تعلم كثيرا من طرق الحماية و بالمقابل سيكتشف ايضا الكثير من طرق كسر الحماية لذلك اخي الكريم لا تجهد نفسك كثيرا في البحث عن طرق الحماية فهناك عقبة كبيرة امام طرق الحماية و هي امان الماكرو اذا حلت هذه المشكلة يستحيل بعدها كسر حماية اي ملف الاخ الحبيب "ابو الحارث" هناك كودان الكود الاول يوضع في حدث Workbook_SheetActivate اما الكود الثاني يوضع في موديل عادي وهذا الملف للتجربة يغلق بعد 2د ارجوا ان اكود قد وصلت الفكرة ... وفقك الله اخي ابو الحارث غلف ملف غير نشط.rar