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

السلام عليكم ورحمة الله وبركاته.. في الوضع الطبيعي الاكسس يعطينا فقط مجموعة الوان عند تنسيقها في الكود Constant Value Description vbBlack 0x0 Black vbRed 0xFF Red vbGreen 0xFF00 Green vbYellow 0xFFFF Yellow vbBlue 0xFF0000 Blue vbMagenta 0xFF00FF Magenta vbCyan 0xFFFF00 Cyan vbWhite 0xFFFFFF White ولكن كثيراً ما نريد ان نقوم بإختيار الواناً غير التي موجودة في الاعلى مثلا اللون الفسفسوري غير موجود في القائمة. قمنا باخذ قيمة اللون الفسفوري من احد برامج تعديل الصور وليكن مثلا الفوتوشوب لكن احيانا تواجهنا مشاكل ورسائل مزعجة من الاكسس عند وضع الالوان عن طريق VBA مثلا انا دائما ماكانت تصادفني رسالة مزعجة Expected Array عندما اقوم بوضع اللون بالصورة الاتية: txt_name.BackColor = RGB(20,30,60) تظهرلي هذه الرسالة: فكرت في تحويل اللون من HEX الى OLE ، وقد تم تغيير اللون بنجاح وبدون اي رسائل خطأ Public Function HEX2OLE(ByVal hexValue As String) As Long Dim R, G, B As Long If Left(hexValue, 1) = "#" Then hexValue = Replace(hexValue, "#", "") R = CByte("&H" & Left(hexValue, 2)) G = CByte("&H" & Mid(hexValue, 3, 2)) B = CByte("&H" & Mid(hexValue, 5, 2)) HEX2OLE = CLng(R + (G * 256) + (B * 65536)) End Function بالتوفيق للجميع. HEX_2_OLE.accdb

السلام عليكم ورحمة الله وبركاته تانية طريقة هنشرحها باذن الله هى طريقة .. شرح تصدير البيانات من الاكسس الى ملف ورد معد مسبقا عن طريق الاشارة المرجعية الفيديو https://youtu.be/VtPEat0Qkqo MS_Export data to Word file.rar

السلام عليكم ورحمة الله وبركاته اهلا بحضرتكم جميعا النهاردة باذن الله هشرح طريقة جديدة .. للتأكد من ملء كافة الحقول قبل الانتقال الى سجل جديد مع الغاء زر الانتر والتاب من الانتقال بهم الى سجل جديد وده شرح فيديو لطريقة تنفيذ الطريقة MS_Be sure to fill in all fields.rar

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

اعتذر لك لم اعمل حفظ للمرفق حيث قمت بالتعديل وهو بالوينرار ولم احفظه مرفق الملف بعد التحديث طبتم واهتديتم AZIZ_up1.rar

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

جرب المرفق Database11.mdb

وعليكم السلام مرفق بعد اجراء بعد التعديلات - تحياتى test3.accdb

استاذي العزيز @محمد سلامة تم تفعيل نسختك

استاذ احمد بدره تستاهل الف الف الف اعجاب لا تؤاخذوني على التاخير في شكركم استاذ احمد بدره يا رائع

اخي @qathi تفضل DatabaseRestartV1.2.accdb DatabaseRestartV1.2.mdb المصدر : http://blog.nkadesign.com/2008/05/06/ms-access-restarting-the-database-programmatically/

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

شكرا لكما معلمينا الأفاضل على الإفادة جزيتم خيرا

بخصوص مشكلة الاستعلام سبق وضعنا الحل بمعية استاذنا الفاضل جعفر

السلام عليكم يمكنك الاستعانة بالرابط التالي : https://www.dummies.com/software/microsoft-office/excel/how-to-use-the-xlookup-function-in-excel-2016/ بن علية حاجي

انا لا افهم ما لزوم الحلقات التكرارية في الكود وهي التي تجعل الملف ثقيلاُ (2000 حلقة) يكفي هذا الماكرو Sub SALIM() Application.ScreenUpdating = False Dim ws As Worksheet Set ws = Worksheets("min") Dim Ro_D%, Ro_A% Ro_D = Cells(Rows.Count, "D").End(3).Row Ro_A = Cells(Rows.Count, "A").End(3).Row With ws .Range("g:f").ClearContents .Cells(2, "f").Resize(Ro_D - 1).Formula = _ "=INDEX($J$2:$J$2000,MATCH(D2,$I$2:$I$2000,0))" .Cells(2, "G").Resize(Ro_A - 1).Formula = _ "=INDEX($Q$1:$Q$6,MATCH(A2,$P$1:$P$6,0))" .Range("g:f").Value = .Range("g:f").Value End With Application.ScreenUpdating = True End Sub

بعد إذن أستاذنا الفاضل بن علية الحاجي تم وضع الكود التالي في حدث Woorbook حتى لا يتم الحفظ عند الخروج ولا تظهر رسالة عند الخروج من الملف Private Sub Workbook_BeforeClose(Cancel As Boolean) With Application If Workbooks.Count = 1 Then .DisplayAlerts = False .Quit Else .EnableEvents = False Me.Close SaveChanges:=False End If End With End Sub __مصغر1 - نسخة - نسخة.xlsm

العفو اخى والحمدلله اللذى بنعمته تتم الصالحات بالتوفيق ان شاء الله طبتم واهتديتم

أستخدم هذا الكود On Error GoTo Err_Form_Open ChangeProperty "AllowBypassKey", 1, 0 fAccessWindow acHide, False, False With New Access.Application Dim strDbName As String strDbName = CurrentProject.Path & "\Start.accdb" .UserControl = True .RunCommand acCmdAppMaximize DoCmd.RunCommand acCmdAppMaximize .OpenCurrentDatabase strDbName, , "K@serwww$0ficena%9o6" End With Application.Quit Exit_Form_Open: Exit Sub Err_Form_Open: MsgBox "خطأً " & " " & vbCr & vbCr & " تم حذف البرنامج أو تم أعادة تسميته ", 0 + 16 + 1572864, "بدأ التشغيل" Application.Quit Resume Exit_Form_Open ::بالتوفيق:: إذا كنت ترى أن هذه المشاركة مفيدة فلا تنسى التقييم

اختي الكريمة @علياء يسرالدين الملف المرفق التالي فيه تعديل بسيط على ماتقدم به الأخ REDA test3.accdb

جميل جدا بارك الله فيك نتمنى منك المزيد من هذه الابداعات

بارك الله فيك أخي محمد اعجبتني الطريقة استمر نسأل الله تعالى أن يجعل ذلك في ميزان حسناتك .

جرب هذا الماكرو Option Explicit Sub get_moulahaza() Dim Dic_Name As Object Dim Dic As Object Dim i%, Ro%, ky Ro = Cells(Rows.Count, 2).End(3).Row Range("j4").CurrentRegion.Offset(2, 1).ClearContents Set Dic_Name = CreateObject("Scripting.Dictionary") Set Dic = CreateObject("Scripting.Dictionary") '============================= For i = 2 To Ro Dic_Name(Cells(i, 2).Value) = vbNullString Next '============================= For Each ky In Dic_Name.Keys For i = 2 To Ro If Cells(i, 4) <> "حاضر" And Cells(i, 2) = ky Then If Not Dic.Exists(Cells(i, 2).Value) Then Dic.Add Cells(i, 2).Value, _ Cells(i, 4) & " " & Cells(i, 3) Else Dic(Cells(i, 2).Value) = _ Dic(Cells(i, 2).Value) & " * " & _ Cells(i, 4).Value & " " & Cells(i, 3) End If End If Next i Next ky With Dic Cells(4, "K").Resize(.Count) = _ Application.Transpose(.Keys) Cells(4, "L").Resize(.Count) = _ Application.Transpose(.Items) End With Set Dic_Name = Nothing: Set Dic = Nothing End Sub الملف مرفق مع الكود Exampl_moulahaza.xlsm

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

الاستاذ الفاضل / @محمد سلامة جميل جدا هذا الموضوع بارك الله فيك وجعله في ميزان حسناتك نرجو المزيد مثل هذه المواضيع

وعليكم السلام-تفضل طريقة تصميم فورم بحث عن طريق لست بوكس5.xlsm

السلام عليكم الظاهر سهوت عن موضوعك جرب هذا التعديل واتمنى من الاخوة من لدية اسكنار يجرب الكود احتمال الاشكالية تكون في نسخة الويندوز لديك Cy_Scan_Ali_2.xlsm

تفضل اخي الكريم UP-Test(2).accdb تحياتي

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

الملف هذا مختلف عن الاول اشوف لديك اوراق كثيره هل لكل عميل صفحة معينه اذا هذا قصدك افضل استخدم ورقة فقط مبيعات ومشتريات لكل العملاء واذا اردت استخراج بيانات عميل معين سوا مبيعات او مشتريات بالامكان عمل هذا بشروط كتقرير مايمنع تكون صفحة واحدة فقط فيها جميع الرحلات حسب فهمي لما شفته في ملفك ليش مايكون بيانات الموظفين لكل رحلة كالصورة 3 وبيانات فواتير المشتريات والمبيعات لكل رحلة كالصورة 2 بحيث يكون في ملفك صفحتين فقط شوف المرفق شكل الصفحات وترتريب الاعمدة اذا هذا بيخدمك بعملك ممكن نعمل عليه مرفق معدل.xlsm

مساء الخير تمت المعالجة حركات معدل1.xlsm

تفضل بعد اذن استاذنا الكبير سليم-يمكنك استخدام هذه المعادلة =IFERROR(VLOOKUP($A10,'Exchange Rate'!$A$2:$B$1000,2,0),"") Employee Expense Report new1.XLSX

Sub test() Dim a As Variant, lr, i, x, s, k, itm Dim bch As Worksheet Set bch = Sheets("Bank Cheque") lr = bch.Cells(Rows.Count, "a").End(xlUp).Row - 1 a = Application.Index(bch.Cells(2, 2).Resize(lr, 21).Value, Application.Evaluate("row(1:" & lr & ")"), Array(1, 2, 6, 7, 8, 13, 16, 20)) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If bch.Cells(i + 1, 4) = Sheets("Sheet4").Range("d3") And bch.Cells(i, 4) <> "" Then If Not .exists(Cells(i + 1, 4)) Then .Add bch.Cells(i + 1, 4), a(i, 1) & Chr(162) & a(i, 2) & Chr(162) & a(i, 3) & Chr(162) & a(i, 4) & Chr(162) & a(i, 5) & Chr(162) & a(i, 6) & Chr(162) & a(i, 7) & Chr(162) & a(i, 8) Else .Item(bch.Cells(i + 1, 4)) = .Item(Cells(i + 1, 4)) & Chr(162) & a(i, 1) & Chr(162) & a(i, 2) & Chr(162) & a(i, 3) & Chr(162) & a(i, 4) & Chr(162) & a(i, 5) & Chr(162) & a(i, 6) & Chr(162) & a(i, 7) & Chr(162) & a(i, 8) End If End If Next k = .keys itm = .items Ct = .Count With Sheets("Sheet4") Range("a8:f10000").ClearContents For i = 1 To Ct x = Split(itm(i - 1), Chr(162)) .Range("a" & 8 + i - 1).Resize(, UBound(x) + 1) = x Next End With End With End Sub اسم الشركة فيD3

السلام عليكم 🙂 اي وقت اشوف رسالة OLE Server ، الحل هو لغة unicode الكمبيوتر جعفر

بعد اذن الاستاذMohamed_Fouad واثراء للموضوع جرب المرفق Bank Cheque.xlsm

و عليكم السلام و رحمة الله تفضل اخى الكريم اتمنى ان يكون هذا هو طلبك Bank Cheque.xlsx

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

السلام عليكم 🙂 هذا ناتج عن خطأ من مايكروسوفت في احد تحديثاتها الاخيرة ، والحل هنا : جعفر

السلام عليكم ,,, الرجاء مراجعه الملف وارجو ان تجد به ما طلبت اخي الكريم ... Time.xlsx

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

تفضل بعد اذن الأستاذ حسين 1مصغر.xlsm

ترحيل خليه محدده بدون التنسيق.xlsm

جرب هذا الملف TEST_new-2.xlsm

ربما يكون المطلوب TEST_new.xlsm

السلام عليكم 🙂 شكرا اخي كاسر ، فلقد تذكرت اني مررت بمثل هذه المشكلة ، ودخت الى ان عرفت المشكلة 🙂 لما تستخدم الاكسس 2007 فما فوق ، فالاكسس يحمي الكمبيوتر ولا يسمح لك ان تفتح اي برنامج ، اذا اردت فتح البرنامج في مجلد "غير موثوق به" ، لذا ، اذا فتحت البرنامج في مجلد غير موثوق به ، سيظهر لك هذا الخط الاصفر ، وبه زر "تمكين المحتوى" : . لذا عليك بضغط الزر ، وسيعمل الكود في برنامجك بطريقة عادية. ولكن ، وحتى لا تحصل على هذه الرسائل دائما ، يجب عليك ان تعمل مجلد/مجلدات موثوق بها : ويجب ان تتأكد من انك سمحت للاكسس ان يعطيك الخط الاصفر : بعد هذا ، المفروض ان برنامجك يشتغل عدل 🙂 ولكن ، هناك مشكلة يقوم بها الكثير من المبرمجين ، وهذه المشكلة في جعل النموذج: منبثق = نعم ، شكلي او مشروط = نعم ، ويجعل النموذج ينفتح على حجم الشاشة (docmd.maximize) : . فلما ينفتح البرنامج ، سيكون الخط الاصفر خلف النموذج ، فلن تراه ، وعليه لن يعمل البرنامج !! جعفر

نعم وهو الملف الوسيط سيتكفل بهذه المهمة تم التعديل المطلوب ولتسهيل الأمر على مسؤول القاعدة اذا اراد مثلا اظهار الكائنات للتعديل أو الإطلاع تمت اضافة زر أمر لاظهار الكا ئنات وشريط الادوات بدل ما يقوم بألغاء كلمة السر ثم اعادة تفعيل الشفت وفتح القاعدة من جديد فقط نقرة زر كل شي يكون أمامه طبعا زر الأمر لازم يكون مخفي عن المستخدم ونقوم بإيجاد طريقة لاظهاره للمسؤول بالنسبةلي بما اني استخدم نظام صلاحيات مستخدمين أضع هذا الكود عند فتح النموذج لاظهار زر الأمر وتفعيله If MyUser.username() = "Kaser906" Then Me![cmd47].Enabled = True Me![cmd47].Visible = True End If الملف بالمرفقات ::بالتوفيق:: إذا كنت ترى هذه المشاركة مفيدة فلا تنسى التقييم FreeKaser906.rar

بعد اذن الاساتذة الكرام هذه المعادلة في الخلية F3 معادلة صفيف (CTRL+SHIFT+ENTER) =MID(E3,1,MIN(IFERROR(FIND(ROW($A$1:$A$100)&" ",E3)+1,""))) هذه المعادلة في الخلية G3 معادلة صفيف (CTRL+SHIFT+ENTER) =MID(E3,MIN(IFERROR(FIND(ROW($A$1:$A$50)&" ",E3)+1,""))+1,LEN(E3)) الملف مرفق صفحة salim salim2.xlsx

السلام عليكم تم التصرف في الجدول وإضافة المعادلات اللازمة للمطلوب (ربما تكون طويلة بعض الشيء)... بن علية حاجي 22222222222.xlsx

تحياتي الخالصة تم عمل المطلوب بالتعديل على معادلات "الترتيب - 2" (وهي معادلات صفيف لكن لا تحتاج إلى تأكيدها بواسطة ctrl+shift+enter). أرجو أن يفي الغرض المطلوب... بن علية حاجي ترتيب اوائل الفصول.rar

من روائع القدر أن يضع الله في دربك من يُنيرون لك الطريق، فهؤلاء وحدهم من يستحقون الشكر والامتنان نعم هو كده تمام شكرا استاذ سليم شكرا استاذ حسين