اذهب الي المحتوي
أوفيسنا

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

  1. أ / محمد صالح

    أ / محمد صالح

    أوفيسنا


    • نقاط

      382

    • Posts

      3,588


  2. kanory

    kanory

    الخبراء


    • نقاط

      146

    • Posts

      1,684


  3. د.كاف يار

    د.كاف يار

    الخبراء


    • نقاط

      114

    • Posts

      1,285


  4. lionheart

    lionheart

    الخبراء


    • نقاط

      99

    • Posts

      141


Popular Content

Showing content with the highest reputation since 22 سبت, 2021 in all areas

  1. السلام عليكم ورحمة الله تعالى وبركاته فكرتى المتواضعة أن يكون هذا الموضوع متجدد باستمرار او على الاقل لى شخصيا ليكون بمثابة هامش صغير ليحتوى على شخابيط وافكار وتلميحات هامة ومتعدده ليسهل الوصول اليها لانى الان اتعب جدا جدا جدا جدا فى البحث داخل المنتدى للوصول الى اى معلومة او فكرة قديمة سوف احاول جاهدا جمع أفكارى بصفة مستمرة ليسهل لى او لاحبائى الرجوع اليها مستقبلا .................. على بركة الله
    9 points
  2. السلام عليكم ورحمة الله وبركاتة فى البداية صورة توضيحية للمقصود الحمد لله الذى بنعمته تتم الصالحات فكرة عمل البرنامج انشاء قوائم احترافة للاكسس باستخدام 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
    9 points
  3. ة افية Register in advance for this wenbinar للتسجيل المسبق لحضور الندوة https://us02web.zoom.us/meeting/register/tZcocOmuqj8qHdYayF8LVF9p8ob5TVpKhGSd
    6 points
  4. السلام عليكم ورحمة الله الاخ 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
    6 points
  5. تفضل <<<<<<<>>>>>>>> Kan_20211007.rar
    6 points
  6. بعد إذن أخي الكريم @ابراهيم الحداد لا نحتاج لعكس الكلام لأنه يظهر الأرقام مقلوبة مثل 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
    6 points
  7. وهذه محاولة ارجو ان يكون هو المطلوب 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 تحياتي
    6 points
  8. وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم 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 تحياتي
    5 points
  9. عليكم السلام و رحمة الله وبركاته الجزء الخاص بتنفيذ المطلوب في الكود الحالي هو هذان السطران 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 بالتوفيق
    5 points
  10. ما السبب الذي يجعلك تحتاج إلى كود يقوم بهذه الوظيفة طالما أن الدالة مدعومة في جميع إصدارات الاكسل؟ نحتاج إلى تحويل الدالة إلى كود vba في حالة كونها دالة جديدة في اصدار جديد ونريد استعمال مميزاتها في الإصدارات القديمة مثل دالة textjoin مثلا اللهم إلا إذا كنت تقصد طريقة استعمالها داخل vba وفي هذه الحالة يمكنك استخدام هذه الطريقة مع تغيير المرجع والشرط كما تريد Application.WorksheetFunction.CountIf(Range("D2:D9"), ">5") بالتوفيق
    5 points
  11. بالخدمة استاذ وتفضل التعديل Database32-3.rar
    5 points
  12. السلام عليكم ورحمة الله استخدم الكود التالى 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
    5 points
  13. طيب جرب المرفق حسب فهمي للموضوع <<<<<<<<<<>>>>>>>>>> اضفتا حقل ترقيم ... الخصم.accdb
    5 points
  14. طيب <<<<<<<<>>>>>>>> اعمل زر وضع فيه هذا الحدث ............ 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, "للمعلومية"
    5 points
  15. استخدم هذا ... <<<<<<<<<>>>>>>>>> .usedRange.rows(1).Interior.Color = vbYellow تفضل ملفك .... export _kanory.accdb
    5 points
  16. تفضل هذه الفكرة 1678743215_.accdb R_RECEIVING.pdf
    5 points
  17. 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
    5 points
  18. هكذا <<<<<>>>>>> 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) & "*'
    5 points
  19. التلميح داخل مربع النص مع علامة مائية فى حالة كان مربع النص فارغ ويختفيان بمجرد التركيز داخل مربه النص او الكتابة ... ToolTip.mdb
    4 points
  20. لا يوجد مشكلة في هذا فقط كتابة مرجع جدول البحث من sheet1 بطريقة صحيحة يمكنك استعمال هذه المعادلة في الخلية B2 في sheet2 =IFERROR(VLOOKUP(A2,Sheet1!A:B,2,0),"") تم استعمال iferror حتى لا يظهر خطأ عند عدم وجود الاسم ومرفق ملفك بعد التعديل لمن لا يعرف كيف يضيف المعادلة في الملف الأصلي بسبب اختلاف نظام الفاصلة بين الأجهزة بالتوفيق عمل فيولوك اب علي صفحتين.xlsx
    4 points
  21. شفافيــــــــــــTransparent Formsــــــــــــة النماذج Transparent Forms.mdb
    4 points
  22. السلام عليكم اتفضل طلبك ان شاء الله مع تعديلات بسيطة مساهمة مني الي جانب مساهمات اخواني الافاضل 1045801237_.accdb
    4 points
  23. اتفضل اضفت العديد من الفلاتر لاضفاء الكثير من المرونة وايضا الترتيب تصاعديا وتنازليا Customers.mdb
    4 points
  24. شرح دالة 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
    4 points
  25. غياب الجمعة عطلة غياب عدا الجمعة.xlsm
    4 points
  26. 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
    4 points
  27. تفضل هذا المثال سيتم حفظ معلومات الدخول في ملف خارجي و سيتم استدعاء معلومات الدخول بعد ادخال اسم المستخدم Database2 (1).mdb
    4 points
  28. 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
    4 points
  29. لاضافة جدول في قاعدة خارجية استخدم الاتي <<<<<<<>>>>>>>> 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
    4 points
  30. 👆 وانا كذلك من رأى استاذى الجليل @kanory ال #C كذلك Visual Studio.NET قد تكون قريبة نوعا ما من اسلوب كتابة الاكواد داخل محرر أكواد الاكسس
    4 points
  31. قد تساعدك هذه القاعدة من تصميم الاخوة بالمنتدى لا اتذكر الاسم db2.mdb
    4 points
  32. اعانك الله اخي عمر وعوضك خيرا ..... اخي الكريم .... نصيحة اخ .. دائما وابدا اعمل نسخ احتياطية لبرامجك سواءا وقت التصميم او وقت العمل عليه ....
    4 points
  33. تفضل حسب طلبك حقل في تذييل الصفحة يظهر رقم النسخة 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
    4 points
  34. طيب <<<<<<<>>>>>>>> ضع هذا الحدث تحت الزر عندك ......... 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
    4 points
  35. 4 points
  36. جرب المرفق واعلمنا بالنتيجة <<<<<<<<>>>>>>> export _kanory.accdb
    4 points
  37. هذا المطلوب لا يتم بالمعادلات لابد من تدخل جراحي (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
    4 points
  38. 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
    4 points
  39. 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
    4 points
  40. تفضل التنسيق في وحدة نمطية export excelw.accdb
    4 points
  41. وهذه مشاركة بطريقة اخرى مع الاساتذة الكرام <<<<<<<>>>>>>> 1678743215_.accdb
    4 points
  42. كود اخي الوزير يعمل بكفاءة .... كيف لا يصفي الباركود ؟؟؟؟؟؟؟
    4 points
  43. بالعكس النتيجة شغال في الحالتين ..... فقط تأكد من اسم الجدول المرتبط .....
    4 points
  44. السلام عليكم ورحمة الله كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم... جدول ديناميكي.xlsx
    4 points
  45. استبدل الكود بالتالي 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
    3 points
  46. تفضل جرب المرفق الترحيل معدل.xlsm
    3 points
  47. هذا الكلام في المرفق ام برنامجك ........... وماهي رسالة الخطأ التي تظهر .....
    3 points
×
×
  • اضف...

Important Information