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

هذه مشاركة مع اخوتي واحبتي ، لعلها تفي بالغرض Public Function Subsalary(GradeNumber As Byte, RankNumber As Byte) As Double Subsalary = Nz(DLookup("GradeSalary", "Degree", "GradeNO=" & GradeNumber & " And RankNO=" & RankNumber), 0) End Function salary3.accdb

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

طيب <<<<<<<>>>>>>>> ضع هذا الحدث تحت الزر عندك ......... 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

اين الجداول من 1 >>>>>>>>>>>> 8 على كل حال العملية سهلة ..... بعد تصميم الجداول الثمانية هنا عدة طرق منها اما ( IF أو Select Case ) ........ وصمم استعلامات الحاق ثمانية الى الجداول الثمانية .....

طيب <<<<<<<<>>>>>>>> اعمل زر وضع فيه هذا الحدث ............ 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, "للمعلومية"

السلام عليكم ورحمة الله وبركاتة فى البداية صورة توضيحية للمقصود الحمد لله الذى بنعمته تتم الصالحات فكرة عمل البرنامج انشاء قوائم احترافة للاكسس باستخدام 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

اسمح بالتعديل من خصائص الحقل ، او من خصائص الفورم .. اذا كان التعديل في الخصائص = لا .. اجعلها = نعم تجدها في : الخصائص / لسان التبويب بيانات المفترض وجود فورم خاص لتعديل الاسعار العامة والخاصة

عليكم السلام إذا قمت بتسجيل ماكرو ستحصل على الكود وبقليل من التعديلات تجعل الكود متغيرا في صف الننهاية الذي رمزه LR هذا هو الكود Sub girlsfirst() Dim sh As Worksheet, lr As Long Set sh = ActiveWorkbook.Worksheets("sheet") lr = sh.Cells(Rows.Count, 3).End(3).Row With sh.Sort .SortFields.Clear .SortFields.Add2 Key:=Range("L10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add2 Key:=Range("C10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("B7:X" & lr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub Sub boysfirst() Dim sh As Worksheet, lr As Long Set sh = ActiveWorkbook.Worksheets("sheet") lr = sh.Cells(Rows.Count, 3).End(3).Row With sh.Sort .SortFields.Clear .SortFields.Add2 Key:=Range("L10"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .SortFields.Add2 Key:=Range("C10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("B7:X" & lr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub بالتوفيق

يمكنك استعمال هذا الكود للتصفية أولا ثم النسخ ثم الحذف Sub copy_filtered_data() If Evaluate("=COUNTIF(I:I,""جاهز"")") > 0 Then Application.ScreenUpdating = 0 Dim lr1 As Long, lr2 As Long lr1 = Sheet1.Cells(Rows.Count, 1).End(3).Row lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row + 1 Sheet1.Range("$A$1:$I$" & lr1).AutoFilter Field:=9, Criteria1:="جاهز" Sheet1.Range("a2:i" & lr1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheet2.Range("A" & lr2) Sheet1.Range("a2:i" & lr1).SpecialCells(xlCellTypeVisible).EntireRow.Delete Sheet1.Range("$A$1:$I$" & lr1).AutoFilter Application.ScreenUpdating = 1 MsgBox "done by mr-mas.com" Else MsgBox "لا يوجد صفوف جاهزة لترحيلها" End If End Sub وهذا ملفك بعد وضع الكود وتغيير الامتداد (لأن معظم الأوقات يكون صاحب الاستفسار لا يعرف كيفية التعامل مع أساسيات الأكواد) بالتوفيق نسخ البيانات بعد الفلتر.xlsb

يمكنك استعمال هذا الكود وهو نفس الكود ولكن بتعديلات بسيطة Sub test() Dim ws As Worksheet, lr As Integer, lr2 As Integer Application.ScreenUpdating = False Sheets("البيان المجمع").Range("a4:e10000").ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> "البيان المجمع" And ws.Name <> "ملاحظات" Then With ws .Activate lr = .Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("البيان المجمع").Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("البيان المجمع").Range("a" & lr2 & ":e" & lr2 + lr - 4).Value = .Range("a4:e" & lr).Value End With End If Next Sheets("البيان المجمع").Activate: Range("a1").Select Application.ScreenUpdating = True End Sub بالتوفيق

فعلا وجدت الحل في رقم 3 شكرا اخي الكريم جزاك الله كل خير وجعله في ميزان حساناتك

بارك الله فيك وجزاك الله خير الحقيقه موضوع مهم ويحتاجة الكثير بانتظار الاصدار الاحدث والشرح وفقك الله

تمام انا عاوزة امسحه وعاوزة انزل نسخة اكسيل مش اونلاين انزلها منين؟

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

تفضل اخي الكربم نحياتي

تفضل هذا التعديل للتوضيح salary.accdb

تفضل هذا التعديل كما بالجدول salary.accdb

تفضل هذا التعديل اذا كانت رواتب الدرجات مختلفة فستجد الموضوع اصبح اسهل من قبل Public Function Subsalary(TotalSalary As Double, Levelsalary As Double) As Double Dim SRank As Double, SGrade As Double SRank = DLookup("RankSalary", "Rank", "RankNO=" & TotalSalary) SGrade = DLookup("GradeSalary", "Degree", "GradeNO=" & Levelsalary) Subsalary = SRank + SGrade End Function salary.accdb

تفضل هذا التعديل نسيت ان احسب مرتبت الراتب و الدرجة هذا التعديل salary.accdb

تفضل التعديل Nz(DSum("[total]", "New_Request", "TCODE= 42 and doctor=" & [doctors] & _ " AND Ddate Between #" & CDate([Forms]![Q_All]![FROM]) & "# And #" & CDate([Forms]![Q_All]![TO]) & "#"), 0) كذلك اذا ما ضبط التنسيق في الأعلا جرب هذا لأنك قد تواجه مشكلة في تنسيق التاريخ حسب تعاملك مع و هذا هو الحل Nz(DSum("[total]", "New_Request", "TCODE= 42 and doctor=" & [doctors] & _ " AND Ddate Between " & Format$(CDate([Forms]![Q_All]![FROM]), "\#mm\/dd\/yyyy hh\:nn\:ss\#") & _ " And " & Format$(CDate([Forms]![Q_All]![TO]), "\#mm\/dd\/yyyy hh\:nn\:ss\#")), 0)

جميعا بإذن الله

لا يمكن حسابها بمعادلة في مكانها سينتج خطأ المرجع الدائري يمكنك استعمال هذه المعادلة في العمود BK مثلا =BF9-FLOOR(BF9,0.05) مع نسخ المعادلة لأسفل وقبل الطباعة يتم نسخ بيانات هذا العمود ( ctrl+c ) ولصقها في المكان المطلوب كقيم (كلك يمين ثم نختار الزر المكتوب عليه 123 ) بالتوفيق

عليكم السلام السطر الذي يقوم بالطباعة هو sh.Range("a1:q30").PrintOutt نقوم بتغييره إلى sh.Range("a1:q30").PrintOutt Copies:=2 بالتوفيق

موضوع اتجاه البحث في vlookup يمكن التغلب عليه الميزة في lookup انها تبحث في الصفوف والأعمدة كبديل للاثنين معا vlookup و hlookup بالتوفيق

يعد اذن اخي على هذا الكود ربما يكون اسرع قليلاٌ لانه يعنمد على المصفوفات Sub move_data() Sheets("تصفية").Cells.ClearContents Dim arr() Dim i%, m%: m = 1 For i = 1 To 50 If i = 11 Then i = 44 ReDim Preserve arr(1 To m) arr(m) = i m = m + 1 Next m = 1 For i = LBound(arr) To UBound(arr) Sheets("تصفية").Cells(2, m).Resize(100, 1).Value = _ Sheets("البيانات").Cells(2, arr(i)).Resize(100, 1).Value m = m + 1 Next Erase arr End Sub

وعليكم السلام تفضلى نقل بيانات.xlsm

========================= الملف الجامع لهذه الاكواد ( اكواد الاستدعاء ) استدعاء بمعيارين من الخارج3.rar

السلام عليكم اخي الكريم اليك احد الطرق -- date.rar

أخي العزيز آل سراج هكذا يكون الشرح ..رغم البساطة الشديدة في الشرح ولكنه يؤدي الغرض ويوصل المطلوب بسهولة أرجو أن يتخذ الأعضاء من المشاركة السابقة نموذج لشرح المطلوب فقد تم توضيح المطلوب في سطرين بدلاً من التطويل في الموضوع بدون داعي وبدون فائدة تذكر إليك الكود التالي وإن شاء الله يفي بالغرض Sub TransferUsingRangesArray() Dim myValues With Sheet2 myValues = Array(.Range("I10"), .Range("H8"), .Range("G9"), .Range("G10"), .Range("J18")) End With With Sheet3 .Range("G" & .Cells(1000, "G").End(xlUp).Row + 1).Resize(1, 5).Value = myValues End With End Sub

بسم الله الرحمن الرحيم شاكر لأخي طارق وأخي يحيى على ما أتحفونا به واسمحوا لي أن أدلو بدلوي (البسيط) في هذا المجال lookup صيغتها Lookup( value, lookup_range, result_range ) حيث value القيمة أو مرجع الخلية المراد البحث عنها lookup_range المدى المراد البحث فيه عن القيمة المطلوبة (ويشترط أن يكون مرتبا ترتيبا تصاعديا وإلا فسترجع الدالة نتائج خاطئة) result_range المدى المراد معرفة نتيجة مقارنته بالعمود الأول فمثلا لمعرفة الاسم (B) الموافق للرقم 25 في عمود المسلسل (A) نستعمل هذه المعادلة بشرط ترتيب عمود المسلسل تصاعديا من الأصغر إلى الأكبر lookup(25,a1:a100,b1:b100) vlookup صيغتها VLookup( value, table_array, index_number, not_exact_match ) حيث value القيمة المراد البحث عنها في العمود الأول من جدول البيانات table_array جدول البيانات المراد البحث عن القيمة في أول عمود من أعمدته وإرجاع القيمة الموجودة في رقم العمود المطلوب index_number رقم العمود المطلوب إخراج النتائج الموافقة للبحث منه not_exact_match قيمته true في حالة البحث غير المطابق عن القيمة الموجودة في المعامل الأول و false في حالة البحث المطابق فمثلا لتنفيذ نفس المثال السابق تكون المعادلة vlookup(25,a1:b100,2,false) طبعا لاحظنا عدم اشتراط الترتيب التصاعدي في عمود المسلسل في هذه الحالة أتمنى أن أكون وفقني الله في إيصال المعلومة بصورة بسيطة ومفهومة

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

بارك الله لك في الحسين أخي يحيى وكتبه الله من الصالحين السعداء في الدنيا والآخرة

بالفعل أخي سالم يجب حفظ الملف الذي يحتوي على أكواد vba في إكسل 2007 بصيغة xlsm وليس xlsx ويكون نوع الملف في شاشة الحفظ excel macro-enabled workbook

يا ريت مزيد من التوضيح

منذ أن رأيت مثال أخي زياد والذي يقوم بتلوين يمين الصف وأعلى العمود للخلية المحددة جاءتني فكرة إكمال العمل الفني الرائع بتلوين باقي الصف (يسار الخلية المحددة) وباقي العمود (أسفل الخلية المحددة) مع تعديل بسيط في معادلة أخي زياد أتمنى أن تنال إعجابكم أخوكم أبو عبد الله محمد صالح mas-acf.rar

شكرا لك أخي زياد ولكن بالتجربة أظهر لي هذا الخطأ opject doesn't support this action وكان موضع الخطأ في With Application.FileSearch

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