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

السلام عليكم ورحمة الله وبركاته.. في الوضع الطبيعي الاكسس يعطينا فقط مجموعة الوان عند تنسيقها في الكود 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/

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

وعليكم السلام 🙂 في الواقع هذه ميزات الاكسس ، عندك اكثر من طريقة لعمل اي شيء 🙂 شكرا لك 🙂 جعفر

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

السلام عليكم و رحمة الله وبركاته استفدت كثيرا من مشاركات الاخوة الاعزاء قبلي و لكن احيانا اعجز عن تعديل الكود ليناسب عملي , ارجو منكم المساعدة ,,, في الملف المرفق , المستخدم للبرنامج يشكو من الاخطاء التي تحدث عند كتابة اسماء الصور الي معالج الماسح الضوئي , و كذلك المسار لمجلد الحفظ ( حيث ان طلبة يتم حفظ الوثائق علي شكل صور JPEG في مجلد عادي ) ,, فهل نستطيع ان نجعل الكود يقوم تلقائيا بنسخ اسم الصور من النموذج العلوي الي نموذج معالح الماسح الضوئي ,,, وجدت في المنتدي مشاركة للاستاذ احمد زمان , و لكني عجزت عن تعديل الكود ليناسب المستخدم و يلبي طلبة , كما انني وجدت كود للاستاذ المبدع ابو هادي في قسم الاكسيس لكنة لم يعمل في الاكسيل ارجو المساعدة ولكم جزيل الشكر majeed.xls

انا لا افهم ما لزوم الحلقات التكرارية في الكود وهي التي تجعل الملف ثقيلاُ (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

أ.emam1424 مش عارف انا فهمت صح ولا لأ .. جرب وولفنى بالنتيجة Saifi.zip

أشكر أستاذنا الأفاضل الأستاذ / أحمد يوسف والأستاذ / عبدالله الصاري على مرورهم الكريم أستاذ hayyan alaa أولاً أشكرك على كلمات الرقيقة ثانيًا لا يهمك حيث كل شخص منا له ظروفه الخاصة المهم أنه تم العمل على الوجه الأكمل بفضل من الله

السلام عليكم تم إضافة الكود التالي في كود حدث كل الشيتات (من بينها ThisWorkBook)... Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Save End Sub ولحذف رسالة "تحذير حول الخصوصية" نتبع خطوات الفيديو (ملف تنفيذي مضغوط) في الملف المرفق (وقد تم ذلك في نسخة أوفيس 2016 بالفرنسية)... بن علية حاجي test.rar

بعد إذن أستاذنا الفاضل بن علية الحاجي تم وضع الكود التالي في حدث 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

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

تفضل new.mdb

السلام عليكم راجع الملف المرفق لعل فيه ما تريد... بن علية حاجي _مصغر1 - نسخة.xlsm

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

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

استاذ محمود رواس كل ده تمام ولكن اين الضغط على الإعجاب ؟ على الرغم ان هذا هو أقل ما يقدم لهم على كل ما قدموه لك

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

ابو عبدالله شكرا عبد اللطيف شكرا الله يعطيكم العافيه

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

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

وبعد اذن جميع الأساتذة وزيادة فى اثراء الموضوع-تفضل Bank Cheque.xlsm

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

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

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

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

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

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

جرب المرفق ::بالتوفيق:: إذا كنت ترى أن هذه المشاركة مفيدة فلا تنسى التقييم Database2.rar

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

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

السلام عليكم بعد اذن استاذنا الكبير بن علية حاجى يمكنك محاولة تفهم المعادلات بنفسك لحسن التعلم فهذه المعادلة تستخدم لفصل المادة : =IF(E3="","",IF(ISERROR(FIND("/",E3,1)),TRIM(MID(E3,1,FIND("الشعبة",E3,1)-1)),TRIM((MID(E3,1,FIND("الشعبة",E3,1)-1))&(MID(E3,FIND("/",E3,1),FIND("الشعبة",E3,1)-1))))) وهذه لفصل الشعبة -فكل ما عليك تغيير رقم الخلية التى بداخل المعادلة للخلية التى تريد الفصل منها =IF(E3="","",IF(ISERROR(FIND("/",E3,1)),TRIM(MID(E3,FIND("الشعبة",E3,1)-1,15)),TRIM(MID(E3,FIND("الشعبة",E3,1)-1,FIND("/",E3,1)-FIND("الشعبة",E3,1)+3))&" "&TRIM(MID(E3,FIND("الشعبة",E3,FIND("/",E3,1)),15)))) اتمنى ان تكون قد تفهمت الموضوع فهو بسيط وسهل

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

السلام عليكم اليك المثال فالنموذج اختر فرع 1 من الكمبوبوكس سيفتح التقرير قد ساعدنى به الاستاذ مارد وهو استاذ @Elsayed Bn Gemy ان شاء الله تستفيد منه تمنياتى لكل بالتوفيق تقرير اجماليات.rar

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

حرب هذا الماكرو Sub RAND_NUM() Dim i%, k%, M%, Y Dim OBJ As Object Range("A5", Range("A4").End(4)).ClearContents Set OBJ = CreateObject("System.Collections.Sortedlist") For i = 1 To [c2] Randomize Y = Rnd() OBJ.Add Y, i Next M = 5 For k = 0 To OBJ.Count - 1 Cells(M, 1) = OBJ.IndexOfValue(k + 1) + 1 M = M + 1 Next End Sub الملف مرفق Rand_numbers.xlsm