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

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

السلام عليكم ورحمة الله وبركاتة فى البداية صورة توضيحية للمقصود الحمد لله الذى بنعمته تتم الصالحات فكرة عمل البرنامج انشاء قوائم احترافة للاكسس باستخدام Ribbon واوامر XML بدون تعب او شقاء او توهان فى الكود🧐 الاعدادات المطلوبة قبل التشغيل : 1- التأكد من ان المنطقة واللغة Arabic(Egypt) ولا يشترط ان تكون مصر فقط بل اى دولة عربية ولكن الاهم اللغة العربية خطوات التشغيل : 1- قم بأنشاء مشروع جديد يحمل مثلا أسم قاعدة البيانات الذى تريد تركيب الريبون عليها ومن ثم تحديد مسارها وستفيد هذه الخطوة أ- يانك سوف تصدر الريبون عليها دون استخدام اى شئ وسوف يكون فى الاصدار التالي بعد ايام ولكن حتى هذا الحين سوف اوضح كيفية التركيب . ب- سوف تستدعلى اسماء النماذج بالقاعدة وستعرف لماذا بالخطوة رقم 4 . 2- قم باختيار قائمة التبويب من الاعلي وانشاء تبويب جديد والحقة بالمشروع المنشئ مسبقاً والتبويب هو ( المشاريع - التبوييب - .... ) كما بالصورة بالاعلي . 3- قم بالدخول على المجموعات ومن ثم انشئ المجموعات داخل التبويب كمجموعة ( أضافة مشروع جديد ) كما بالصورة بالاعلي . 4- قم بالدخول لتاب العناصر والكنترول ومن ثم انشئ العناصر الذى تريدها داخل المجموعة المنشئه بالخطوة رقم 3 وعند اختيار نوع الكنترول انه Button سوف تجد اسماء النماذج بالقاعدة المحددة مسبقاً بالخطوة رقم 1 . 5- وبعد الانتهاء توجة الى المشاريع وافتح المشروع ومن ثم تصدير ملف Txt خطوات التركيب بالبرنامج لديك 1- قم بالضعط كليك يمين على ايقونه البرنامج بسطح المكتب الخاص بك ومن ثم open file location ستجد ملفان هما (basGDIPlus.bas - RibbonFunctions.bas) استدعهما من محرر الاكواد VB 2- وبعد ذلك قم بانشاء جدول تحت مسمي USysRibbons وبداخلة ثلاث حقول وهم Field Name Field Type Field Size ID AutoNumber Long Integer RibbonName Text 255 RibbonXml Memo وبحقل RibbonName اكتب اسم الشريط وبحقل RibbonXml قم بلصق الملف المصدر من البرنامج بالخطوة رقم 5 بالاعلى . ويجب ان تغلق قاعدة البيانات وتعيد فتحها بعد نسخ الشريط حتى يتم تحميلة ويظهر فى خصائص النموذج ومن اعدادت النموذج ثم غير ذلك ثم اسم الشرط اختار اسم الشريط لتجده ظاهراً وقريباً سوف اقوم بعمل فيديو توضيحي مع الاصداء الاحدث وبالتوفيق للجميع . AccessRibbonMaker.zip

ة افية Register in advance for this wenbinar للتسجيل المسبق لحضور الندوة https://us02web.zoom.us/meeting/register/tZcocOmuqj8qHdYayF8LVF9p8ob5TVpKhGSd

السلام عليكم ورحمة الله الاخ ABOU ELSAAD يمكنك استخدام الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long Dim a As Integer, b As Integer, d As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then a = WorksheetFunction.Min(ws.Range("A" & x & ":AE" & x)) b = WorksheetFunction.Max(ws.Range("A" & x & ":AE" & x)) ab = b - a + 1 d = WorksheetFunction.Count(ws.Range("A" & x & ":AE" & x)) If ab = d And d > 1 Then Abst = " يوم " & " (" & a & " - " & b & ")" ws.Range("AL" & x) = Abst Else Abst = C.Value & Com & Abst ws.Range("AL" & x) = Left(Abst, Len(Abst) - 1) End If End If Next C Abst = "" x = x + 1 Loop End Sub

تفضل <<<<<<<>>>>>>>> Kan_20211007.rar

بعد إذن أخي الكريم @ابراهيم الحداد لا نحتاج لعكس الكلام لأنه يظهر الأرقام مقلوبة مثل 13 تظهر 31 وهكذا هذا جهدي المتواضع في هذا المجال Sub AbsDays() Dim ws As Worksheet, C As Range, LR As Long, x As Long Set ws = Sheets("SS") LR = ws.Range("AG" & Rows.Count).End(xlUp).Row For x = 3 To LR ws.Range("AI" & x) = "" For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then ws.Range("AI" & x) = ws.Range("AI" & x) & IIf(ws.Range("AI" & x) = "", "يوم ", " و") & C.Value Next C : Next x MsgBox "Done by mr-mas.com" End Sub بالتوفيق ترحيل أيام الغياب.xlsb

وهذه محاولة ارجو ان يكون هو المطلوب mySQL = "Select * From tblData ORDER BY ID" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst For i = 1 To Int(rst.RecordCount / 5) Me.List1.AddItem rst!CustCode rst.MoveNext Next For i = (List1.ListCount + 1) To (List1.ListCount + Int(rst.RecordCount / 5)) Me.List2.AddItem rst!CustCode rst.MoveNext Next For i = (List2.ListCount + 1) To (List2.ListCount + Int(rst.RecordCount / 5)) Me.List3.AddItem rst!CustCode rst.MoveNext Next For i = (List3.ListCount + 1) To (List3.ListCount + Int(rst.RecordCount / 5)) Me.List4.AddItem rst!CustCode rst.MoveNext Next For i = (List4.ListCount + 1) To (List4.ListCount + rst.RecordCount / 5) Me.List5.AddItem rst!CustCode rst.MoveNext Next rst.Close Test77.rar تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم On Error Resume Next If IsNull([b3]) Then MsgBox "يجب أولا أختــــــــــيار اسم المورد", vbCritical, "warning" Else DoCmd.OpenReport "QPa_yme3 ", acViewPreview, , "[Da_pay4]=#" & Format(Me.b3, "mm/dd/yyyy") & "#" DoCmd.RunCommand acCmdZoom100 End If العملاء.rar تحياتي

عليكم السلام و رحمة الله وبركاته الجزء الخاص بتنفيذ المطلوب في الكود الحالي هو هذان السطران ar.Offset(, -2) = ar.Offset(, 1).Value ar.Value = 0 إذا لاحظت ستجد أن المتغير ar يعني خلية العلاوة الدورية والدالة offset للانتقال من هذه الخلية عددا من الصفوف أولا ثم الأعمدة ثانيا وبناء عليه يكون تم وضع قيمة العمود التالي للعلاوة ar.Offset(, 1).Value (المرتب الحالي) في العمود السابق لها بعمودين ar.Offset(, -2) (المرتب السابق) وبملاحظة ترتيب الأعمدة في مطلوبك الجديد ستجد أن المرتب المجرد قبلها ب 3 أعمدة يعني -3 في المعامل الثاني لدالة offset قيمته = نفس قيمته + قيمة العلاوة الدورية وعليه يكون الكود ar.Offset(, -3) = ar.Offset(, -3).Value + ar.Value ويمكن وضعه قبل السطرين في حالة الاحتفاظ بدورهما ويمكن حذف هذا الجزء .SpecialCells(xlConstants).Areas من هذا السطر تجنبا لحدوث أية أخطاء For Each ar In sh.Cells(3, 6).Resize(lr).SpecialCells(xlConstants).Areas بالتوفيق

ما السبب الذي يجعلك تحتاج إلى كود يقوم بهذه الوظيفة طالما أن الدالة مدعومة في جميع إصدارات الاكسل؟ نحتاج إلى تحويل الدالة إلى كود vba في حالة كونها دالة جديدة في اصدار جديد ونريد استعمال مميزاتها في الإصدارات القديمة مثل دالة textjoin مثلا اللهم إلا إذا كنت تقصد طريقة استعمالها داخل vba وفي هذه الحالة يمكنك استخدام هذه الطريقة مع تغيير المرجع والشرط كما تريد Application.WorksheetFunction.CountIf(Range("D2:D9"), ">5") بالتوفيق

بالخدمة استاذ وتفضل التعديل Database32-3.rar

السلام عليكم ورحمة الله استخدم الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long, y As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then Abst = Abst & C.Value & Com ws.Range("AL" & x) = StrReverse(Left(Abst, Len(Abst) - 1)) End If Next C Abst = "" x = x + 1 Loop End Sub

طيب جرب المرفق حسب فهمي للموضوع <<<<<<<<<<>>>>>>>>>> اضفتا حقل ترقيم ... الخصم.accdb

طيب <<<<<<<<>>>>>>>> اعمل زر وضع فيه هذا الحدث ............ Dim msgstyle Dim Rs As DAO.Recordset Dim Rs2 As DAO.Recordset Dim rstChild As Recordset Dim rstChild2 As Recordset Dim rstChild3 As Recordset Dim rstChild4 As Recordset Set Rs2 = CurrentDb.OpenRecordset("select * from proces where [id] Like '" & [id] & "*'") Set Rs = CurrentDb.OpenRecordset("local") Do While Not Rs2.EOF Rs.AddNew Set rstChild = Rs!vend.Value Set rstChild2 = Rs2!vend.Value Set rstChild3 = Rs!sisi.Value Set rstChild4 = Rs2!sisi.Value Rs!id_f = Rs2!id Do While Not rstChild2.EOF rstChild.AddNew rstChild.Fields(0) = rstChild2.Fields(0) rstChild.Update rstChild2.MoveNext Loop Do While Not rstChild4.EOF rstChild3.AddNew rstChild3.Fields(0) = rstChild4.Fields(0) rstChild3.Update rstChild4.MoveNext Loop Rs.Update Rs2.MoveNext Loop Set Rs = Nothing MsgBox Space(20) & "تمت العملية بنجاح.." & Space(20), msgstyle, "للمعلومية"

استخدم هذا ... <<<<<<<<<>>>>>>>>> .usedRange.rows(1).Interior.Color = vbYellow تفضل ملفك .... export _kanory.accdb

تفضل هذه الفكرة 1678743215_.accdb R_RECEIVING.pdf

Sub Test() Dim x, temp, myDir As String, fn As String, wsName As String myDir = ThisWorkbook.Path & "\" fn = "B.xlsx" wsName = ActiveSheet.Name If Dir(myDir & fn) = "" Then MsgBox "Workbook Not Found", vbExclamation: Exit Sub On Error Resume Next x = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & wsName & "'!R1C1") temp = Err.Number On Error GoTo 0 If (temp = 0) * (Not IsError(x)) Then With ActiveSheet.Range("A1:A8") .Formula = "='" & myDir & "[" & fn & "]" & wsName & "'!F4" .Value = .Value End With Else MsgBox "Worksheet Not Found", vbExclamation End If End Sub

هكذا <<<<<>>>>>> DoCmd.OpenReport "rpt_class", acViewPreview, , "class Like '*" & Me.lst4.Column(1) & "*' AND class Like '*" & Me.lst4.Column(1) & "*'" دائما الشروط تكتب بين علامتي تنصيص انظر للكود بعد تفريغ الشرطين يصبح هكذا DoCmd.OpenReport "rpt_class", acViewPreview, , "هنا بكتب جميع الشروط والمعاريير" وهذا شكل الشرطين class Like '*" & Me.lst4.Column(1) & "*' AND class Like '*" & Me.lst4.Column(1) & "*'

التلميح داخل مربع النص مع علامة مائية فى حالة كان مربع النص فارغ ويختفيان بمجرد التركيز داخل مربه النص او الكتابة ... ToolTip.mdb

لا يوجد مشكلة في هذا فقط كتابة مرجع جدول البحث من sheet1 بطريقة صحيحة يمكنك استعمال هذه المعادلة في الخلية B2 في sheet2 =IFERROR(VLOOKUP(A2,Sheet1!A:B,2,0),"") تم استعمال iferror حتى لا يظهر خطأ عند عدم وجود الاسم ومرفق ملفك بعد التعديل لمن لا يعرف كيف يضيف المعادلة في الملف الأصلي بسبب اختلاف نظام الفاصلة بين الأجهزة بالتوفيق عمل فيولوك اب علي صفحتين.xlsx

شفافيــــــــــــTransparent Formsــــــــــــة النماذج Transparent Forms.mdb

السلام عليكم اتفضل طلبك ان شاء الله مع تعديلات بسيطة مساهمة مني الي جانب مساهمات اخواني الافاضل 1045801237_.accdb

اتفضل اضفت العديد من الفلاتر لاضفاء الكثير من المرونة وايضا الترتيب تصاعديا وتنازليا Customers.mdb

شرح دالة DateAdd تعد دالة DateAdd من دوال الوقت والتاريخ المهمة حيث تستخدم في إضافة مدة معينة على تاريخ معين تتطلب دالة DateAdd تحديد ثلاثة متغيرات هي : 1- نوع الفترة التي تريد إضافتها وهل هي يوم ِأم شهر أم سنة أم ساعة أو ..... إلخ ( التي تريد إضافتها ) 2- العدد أي ما هو عدد الأيام أو الأشهر أو السنوات أو الساعات أو ..... إلخ ( التي تريد إضافتها ) 3- التاريخ الذي تريد الإضافة إليه وتستخدم الدالة بالصيغة التالية : 'Syntax : DateAdd(interval, number, date) DateAdd(التاريخ, العدد, نوع الفترة) 'Examples : x = DateAdd("yyyy", 1, Date()) x = DateAdd("m", 5, Date()) x = DateAdd("d", 14, Date()) Interval Description yyyy Year q Quarter m month y Day of the year d Day w Weekday ww Week h hour n Minute s Second

غياب الجمعة عطلة غياب عدا الجمعة.xlsm

Sub Test() Dim r As Range, c As Long Application.ScreenUpdating = False With ActiveSheet Set r = .Range("L4:L" & .Cells(Rows.Count, "L").End(xlUp).Row) c = .Cells(4, Columns.Count).End(xlToLeft).Column + 1 .Cells(4, c).Resize(r.Rows.Count).Value = r.Value End With Application.ScreenUpdating = True End Sub

تفضل هذا المثال سيتم حفظ معلومات الدخول في ملف خارجي و سيتم استدعاء معلومات الدخول بعد ادخال اسم المستخدم Database2 (1).mdb

Private Sub TextBox1_Change() Dim dFrom As Date, dTo As Date, lr As Long With ActiveSheet lr = .Range("B" & Rows.Count).End(xlUp).Row If TextBox1.Text <> "" Then .AutoFilterMode = False dFrom = .Range("F1").Value2 dTo = .Range("G1").Value2 With .Range("B2:Q" & lr) .AutoFilter Field:=1, Criteria1:="=" & TextBox1.Text & "*", Operator:=xlOr .AutoFilter 8, ">=" & CLng(dFrom), xlAnd, "<=" & CLng(dTo) End With Else .AutoFilterMode = False End If End With End Sub

لاضافة جدول في قاعدة خارجية استخدم الاتي <<<<<<<>>>>>>>> Dim msgstyle Dim strSQL1 As String Dim b As New Access.Application Set b = CreateObject("Access.Application") b.OpenCurrentDatabase (Me.txtPath) strSQL1 = "CREATE TABLE [kanory] ([ProductID] AUTOINCREMENT,[ProductName] TEXT(40) NOT NULL,[SupplierID] LONG,[BirthDate] DATETIME,[CategoryID] LONG,[QuantityPerUnit] TEXT(20),[UnitPrice] CURRENCY,[UnitsInStock] SMALLINT,[UnitsOnOrder] SMALLINT,[ReorderLevel] SMALLINT,[Discontinued] BIT NOT NULL,CONSTRAINT [PrimaryKey] PRIMARY KEY ([ProductID]));" b.DoCmd.RunSQL strSQL1 MsgBox Space(20) & "تم انشاء الجدول Kanory بنجاح.." & Space(20), msgstyle, "للمعلومية" Set b = Nothing اما لتعديل خصائص حقل موجود في الجدول استخدم التالي مع ملاحظة : ان اختلاف البيانات قي الحقل اذا كانت هنا بيانات ممكن تفقدها :::: <<<<<>>>>>>> Dim msgstyle Dim b As DAO.Database Dim strFieldName As String Set b = DBEngine.OpenDatabase(Me.txtPath) With b.TableDefs("Kanory").Fields("S_Name") .Properties.Append .CreateProperty("DisplayControl", dbInteger, AcControlType.acComboBox) .Properties.Refresh End With MsgBox Space(20) & "تم انشاء الجدول Kanory بنجاح.." & Space(20), msgstyle, "للمعلومية" b.Close Set b = Nothing

تفضل 2APE.rar

👆 وانا كذلك من رأى استاذى الجليل @kanory ال #C كذلك Visual Studio.NET قد تكون قريبة نوعا ما من اسلوب كتابة الاكواد داخل محرر أكواد الاكسس

قد تساعدك هذه القاعدة من تصميم الاخوة بالمنتدى لا اتذكر الاسم db2.mdb

وعليكم السلام لغة #C

اعانك الله اخي عمر وعوضك خيرا ..... اخي الكريم .... نصيحة اخ .. دائما وابدا اعمل نسخ احتياطية لبرامجك سواءا وقت التصميم او وقت العمل عليه ....

تفضل حسب طلبك حقل في تذييل الصفحة يظهر رقم النسخة Dim i As Integer countPrint = 1 Do Until i = Me.[pallet order].Value i = i + 1 DoCmd.OpenReport "master card query", acViewNormal countPrint = countPrint + 1 Loop master card2.rar

طيب <<<<<<<>>>>>>>> ضع هذا الحدث تحت الزر عندك ......... If Me.الوظيفة = "اداري" Then DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO 1 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 2 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 3 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 4 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" MsgBox Space(20) & "تمت العملية بنجاح.." & Space(20), msgstyle, "للمعلومية" DoCmd.SetWarnings True ElseIf Me.الوظيفة = "معلم" Then DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO 5 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 6 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 7 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" DoCmd.RunSQL "INSERT INTO 8 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب]));" MsgBox Space(20) & "تمت العملية بنجاح.." & Space(20), msgstyle, "للمعلومية" Else MsgBox Space(20) & "الرجاء اختيار الوظيفة.." & Space(20), msgstyle, "تحذير" End If

انظر الصور ربما تفي بالغرض <<<<<<<>>>>>>>

جرب المرفق واعلمنا بالنتيجة <<<<<<<<>>>>>>> export _kanory.accdb

هذا المطلوب لا يتم بالمعادلات لابد من تدخل جراحي (vba) يمكنك استعمال هذا الكود في حدث عند التغيير Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 3 And Target.Column >= 1 And Target.Column <= 3 And Evaluate("=counta(a3:d3)") = 4 Then lr1 = Cells(Rows.Count, 1).End(3).Row + 1 lr1 = IIf(lr1 < 4, 4, lr1) lr2 = Cells(Rows.Count, 12).End(3).Row + 1 Range("a" & lr1 & ":d" & lr1).Value = Range("a3:d3").Value Range("l" & lr2 & ":o" & lr2).Value = Range("a3:d3").Value Range("a3:c3").ClearContents End If End Sub وهذا ملفك بعد إضافة الكود وتغيير الامتداد 555.xlsb

Public Sub CMDSEARCH_Click() Dim x, ws As Worksheet, i As Long, j As Long, lastRow As Long With Me.ListBox1 .Clear .ColumnCount = 7 .ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" .ColumnHeads = 0 Set ws = Sheets("Ledger") x = Application.Match(ComboBox1.Value, ws.Rows(1), 0) If Not IsError(x) Then lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row For i = 1 To lastRow If TextBox1 <> "" And InStr(ws.Cells(i, x), TextBox1) <> 0 Then .AddItem .List(j, 0) = ws.Cells(i, 1) .List(j, 1) = ws.Cells(i, 3) .List(j, 2) = ws.Cells(i, 4) .List(j, 3) = ws.Cells(i, 16) .List(j, 4) = ws.Cells(i, 17) .List(j, 5) = ws.Cells(i, 18) .List(j, 6) = ws.Cells(i, 10) j = j + 1 End If Next i End If End With End Sub

First correct the combobox name from [Calss] to [Class] In userform module Dim ws As Worksheet, m As Long Private Sub StudentName_Enter() Dim a, i As Long, k As Long If Natija.Value <> "" And Class <> "" Then a = ws.Range("A2:D" & m).Value ReDim b(1 To UBound(a, 1)) For i = LBound(a) To UBound(a) If Val(a(i, 3)) = Val(Class.Value) And a(i, 4) = Natija.Value Then k = k + 1 b(k) = a(i, 2) End If Next i If k > 0 Then ReDim Preserve b(1 To k): StudentName.List = b End If End Sub Private Sub UserForm_Initialize() Dim a Set ws = Worksheets("Sheet1") m = ws.Cells(Rows.Count, "B").End(xlUp).Row a = GetDistinct(ws.Range("D2:D" & m)) Natija.List = a a = GetDistinct(ws.Range("C2:C" & m)) Class.List = a End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim vArr, v, dic As Object Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function

تفضل التنسيق في وحدة نمطية export excelw.accdb

وهذه مشاركة بطريقة اخرى مع الاساتذة الكرام <<<<<<<>>>>>>> 1678743215_.accdb

كود اخي الوزير يعمل بكفاءة .... كيف لا يصفي الباركود ؟؟؟؟؟؟؟

بالعكس النتيجة شغال في الحالتين ..... فقط تأكد من اسم الجدول المرتبط .....

السلام عليكم ورحمة الله كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم... جدول ديناميكي.xlsx

استبدل الكود بالتالي Select Case Nz([Total Cholesterol], "") Case "": Me.Text15 = "" Case 5.2 To 6.2: Me.Text15 = "Borderline" Case Is < 5.2: Me.Text15 = "Desirable" Case Is > 6.2: Me.Text15 = "High risk of heart disease " End Select

تفضل جرب المرفق الترحيل معدل.xlsm

هذا الكلام في المرفق ام برنامجك ........... وماهي رسالة الخطأ التي تظهر .....

بارك الله فيك وبالتوفيق .....