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

السلام عليكم و رحمة الله و بركاته ماشاء الله عليك يا ابا عبدالله استفدنا كثير من مشاركتك الذهبية و فعلا كود رائع‘ وتحية لاستاذ الغالي ابا خليل الذي هو سبب الغنيمة هذا. و لتغير لون خلفية حقول بدلا من خلفية تفصيل قمت باضافة بسيطة على الكود كما في مرفق. UP-db1.mdb

وعليكم السلام ورحمة الله وبركاته تفضل يا غالي Option Compare Database Option Explicit Dim X1 As Boolean Private Sub GroupHeader0_Format(Cancel As Integer, FormatCount As Integer) If X1 Then Detail.BackColor = 16777199 Else Detail.BackColor = 14877777 End If X1 = Not (X1) End Sub UP-db1.mdb تحياتي

ربما هذا الكود يفي بالغرض Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column = 1 And Target.Count = 1 And _ Application.CountIf(Range("salim_rg"), Target) <> 0 And Target.Offset(1) = "Total" Then ADD_rows (Target.Row) With Target.Offset(2, 1) .Formula = "=sum(B3:B" & Target.Row & ")" .Offset(, 1).Formula = "=sum(C3:C" & Target.Row & ")" .Offset(, 2).Formula = "=sum(D3:D" & Target.Row & ")" End With End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++ Sub ADD_rows(n%) Dim MyRows As Integer MyRows = Range("A3").CurrentRegion.Rows.Count + 2 Rows(n + 1).Insert Shift:=xlDown Cells(n, 1).Offset(, 1).Resize(, 3).Formula = _ "=VLOOKUP($A" & n & ",salim_rg,COLUMNS($A$1:A1)+1,0)" End Sub الملف للمعاينة مرفق Auto_Load.xlsm

تفضل الحل في الصورة لا يمكن العمل لانه لا مجال لرؤية اعمدة الخلايا ولا صفوفها (من اين اعرف اني اتعامل مع الخلية D2 واستنتاج المطلوب من الخلية F2 مثلاُ) و بالتالي كيف تكتب معادلة Exemple.xlsx

ياسلام عليك يابو عبدالله تصدق الكود هذا موجود عندي استخدمه في تفصبل التقرير للتمييز بين الأسطر ولم يخطر ببالي لمستك الرقيقة الساحرة بانشاء مقطع الــ id الف شكر وسلمت أناملك

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

السلام عليكم هذه 3 ملفات للاخوة بالمتدى اتمنى ان تكون هي المطلوب تحياتي ClosePro-M.rar Demo Version.rar إيقاف بالمدة.rar

عذرا لخطاء غير مقصودة PhotoD.rar

تفضل أخي @مازن الحسيني وأعلمنا بالنتيجة ..... مثال.rar

شرح مختصر وافي وللفائدة بحثت عن بقية رموز العناصر فخرجت بهذه النتيجة : 126 - acAttachment 108 - acBoundObjectFrame 106 - acCheckBox 111 - acComboBox 104 - acCommandButton 119 - acCustomControl 103 - acImage 100 - acLabel 102 - acLine 110 - acListBox 114 - acObjectFrame 105 - acOptionButton 107 - acOptionGroup 124 - acPage 118 - acPageBreak 101 - acRectangle 112 - acSubform 123 - acTabCtl 109 - acTextBox 122 - acToggleButton

وياك وياك اخي العزيز

جزاك الله خيرا اخى @Abu Farid وكود جميل وممتاز بارك الله فيك وزادك الله من فضله وعلمه تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

ابشر استاذنا رقم 109 هو رمز نوع عنصر مربع نص (حقل) يمكن تغيره الى If TypeOf ctl Is TextBox Then و هذا لاستثاء حقول مراد تغير لون خلفيته من باقي عناصر محتمل وجودهم في تفصيل كـ تسمية، إطار... و Backstyle هو نمط خلفية عنصر و رقم 1 هو خيار الثاني في خاصية نمط خلفية عنصر(عادي) و 0 هو خيار الاول (شفاف) وفي حال اختيار خيار شفاف مسبقا، لا ينطبق عليه الكود يجب جعله اول عادي ثم تغير لون خلفيتة في الكود

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

وعليكم السلام-يمكنك استخدام وتطويع هذا الكود Sub SplitWorkbook() Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Application.ScreenUpdating = False Set xWb = Application.ThisWorkbook DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = xWb.Path & "\" & xWb.Name & " " & DateString MkDir FolderName For Each xWs In xWb.Worksheets xWs.Copy If Val(Application.Version) < 12 Then FileExtStr = ".xls": FileFormatNum = -4143 Else Select Case xWb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If Application.ActiveWorkbook.HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum Application.ActiveWorkbook.Close False Next MsgBox "You can find the files in " & FolderName Application.ScreenUpdating = True End Sub

اخي اليك احد محاولات FILTER.accdb

السلام عليكم ورحمة الله وبركاته الاستعلام يُعتبر العمود الفقري لقواعد البيانات ، وكلما زادت معرفتنا به ، كلما يصبح البرنامج افضل واسرع 🙂 البحث/التصفية في الاستعلام من الطرق المهمة ، ولكن وللأسف الشديد ، ارى الكثير من المبرمجين لا يعرفون الطريقة الصحيحة في عملها ، فالطريقة الغير صحيحة قد تعطيك النتائج ولكن على حساب وقت تنفيذ الاستعلام 😞 الامثله هنا تقوم على انه يوجد لدينا نموذج اسمه frm_Main ، وبه حقل الاسم fName ، وحقل التاريخ:من Date_From ، وحقل التاريخ:الى Date_To ، والحقول في الاستعلام ، حقل الاسم fName ، وحقل التاريخ DateX . 1. اذا اردنا البحث عن اسم كامل (وليس جزء من اسم) ، فيجب ان يكون المعيار في الاستعلام: [forms]![frm_Main]![fName] 2. واذا كان حقل الاسم فارغا في النموذج ، ونريد ان نرى جميع الاسماء ، فالمعيار يصبح: iif(len([forms]![frm_Main]![fName] & '')=0,[fName],[forms]![frm_Main]![fName]) والشرح للتأكد بأن الحقل فارغ في النموذج، بدل ان نكتب IsNull([forms]![frm_Main]![fName]) or [forms]![frm_Main]![fName]=0 فإننا نختصر هذين الشرطين بشرط واحد len([forms]![frm_Main]![fName] & '')=0 iif(كان الحقل فارغ في النموذج,[fName] اعطنا جميع بيانات الحقل,[forms]![frm_Main]![fName]واذا كان الحقل به قيمة فاستعمل هذه القيمة) . 3. اذا اردنا البحث عن جزء من الاسم Like IIf(Len([forms]![frm_Main]![fName] & '')=0,"*","*" & [forms]![frm_Main]![fName] & "*") والشرح IIf(Len([forms]![frm_Main]![fName] & '')=0 نعم Like "*" لا Like "*" & [forms]![frm_Main]![fName] & "*") . 4. اذا اردنا البحث بين تاريخين بدون سجلات التاريخ الفارغة Between (IIf(Len([Forms]![frm_main]![Date_From] & '')=0,#01-Jan-1900#,[Forms]![frm_main]![Date_From])) And (IIf(Len([Forms]![frm_main]![Date_To] & '')=0,#01-Jan-2900#,[Forms]![frm_main]![Date_To])) والشرح Between (IIf(Len([Forms]![frm_main]![Date_From] & '')=0,#01-Jan-1900#,[Forms]![frm_main]![Date_From])) And (IIf(Len([Forms]![frm_main]![Date_To] & '')=0,#01-Jan-2900#,[Forms]![frm_main]![Date_To])) مع سجلات التاريخ الفارغة Between (IIf(Len([Forms]![frm_main]![Date_From] & '')=0,#01-Jan-1900#,[Forms]![frm_main]![Date_From])) And (IIf(Len([Forms]![frm_main]![Date_To] & '')=0,#01-Jan-2900#,[Forms]![frm_main]![Date_To])) Or [DateX] Is Null والشرح Between (IIf(Len([Forms]![frm_main]![Date_From] & '')=0,#01-Jan-1900#,[Forms]![frm_main]![Date_From])) And (IIf(Len([Forms]![frm_main]![Date_To] & '')=0,#01-Jan-2900#,[Forms]![frm_main]![Date_To])) Or [DateX] Is Null او طريقة استاذنا واخونا العود ابو خليل Between nz([forms]![frm_main]![Date_From];"01/01/1900") And nz([forms]![frm_main]![Date_To];"01/01/2100") . جعفر

تفضل اخي كانت مشكلة في زيادة حجم الملف PhotoC.rar و هذا الثاني PhotoD.rar

يعلم الله اني اتشرف ان اكون تلميذك استاذنا الفاضل @ابوخليل دمتم بكل خير تحياتي

الملف بالمسار الخاص بك Test_21.xls

بعد إذن أستاذنا الفاضل سليم لإثراء الموضوع جرب هذا عن طريق تكست بوكس البحث.xlsm

تفضل ..... مثال.rar

السلام عليكم اساتذتي واحبتي الأعزاء في المرفق تقرير يعرض السجلات كمجموعات ، حيث تجدون ان كل عدد من السجلات تشترك في حقل الـــ id بمعنى ان الرقم في حقل id مكرر في اكثر من سجل ستلاحظون وجود سجل واحد فقط ومجموعة مكونة من سجلين ومجموعة أكثر المطلوب : تطبيق لونين فقط على مجموعة السجلات مثلا الأبيض والرمادي بحيث تتمييز كل مجموعة بلون والمجموعة التي بعدها باللون الآخر وهكذا ... الفكرة : هي تمييز كل مجموعة عن ما بعدها من اجل تيسير الملاحظة والمتابعة ، وان صعب التطبيق لا بأس من تطبيق الفكرة بغير الألوان وبطرق أخرى مثلا بخط فاصل ونحو ذلك .. تقبلوا شكري وتقديري db1.mdb

يمكنك استعمال هذا الماكرو البسيط انسخه الى مديول واربططه بزر في شيت sadol1 Option Explicit Sub test() Dim SD1 As Worksheet Dim SD2 As Worksheet Dim lr1, lr2, lr3, lr4 Application.ScreenUpdating = False Set SD1 = Sheets("sadok1") Set SD2 = Sheets("sadok2") lr1 = SD1.Cells(Rows.Count, "b").End(3).Row lr2 = SD1.Cells(Rows.Count, "s").End(3).Row SD1.Range("b8:o" & lr1).Copy lr3 = SD2.Cells(Rows.Count, "b").End(3).Row + 1 SD2.Range("b" & lr3).PasteSpecial SD1.Range("s8:af" & lr2).Copy lr4 = SD2.Cells(Rows.Count, "s").End(3).Row + 1 SD2.Range("s" & lr4).PasteSpecial Application.CutCopyMode = False SD1.Range("b8:o10000").ClearContents SD1.Range("s8:af10000").ClearContents Application.ScreenUpdating = True End Sub

شاهد الرابط

اخي واستاذي kanory المحترم كل الشكر والتقدير لحضرتك وبارك الله فيك . تمت التجربة وكانت ناجحة اكرر شكري وتقديري وامتناني

اذا كنت قد فهمت عليك ماذا تريد اليك هذا الحل For_Dev.xlsx

السلام عليكم مشاركه مع اخى علاء ونرجو منك فضلا لا امرا ان ترفق مثالا لما تطلب ارفق لك مثال لاخ عزيز جزاه الله خيرا وجميع اخوانى واساتذتى الافاضل تقبل تحياتى وتمنياتى لكم وللجميع بالتوفيق رسالة بالتكرار ويعطي الاسم المتكررR.rar

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

السلام عليكم في الاستعلام حقل تاريخ الايرادات ضع في المعيار هذا الكود يعطيك الايرادات بين التاريخين Between #22/01/2020# And #23/01/2020# كذلك مرفق لاحد الاخوة بالموقع اتمنى يكون هذا المطلوب test-2.rar

تكرما وتفضلا ابا فريد هلا شرحت لنا هذين السطرين If ctl.ControlType = 109 Then ctl.BackStyle = 1 الموجودة ضمن الكود ادناه ماذا تعني هذه الارقام 109 و 1 وهل هناك ارقام اخرى لها خصائص مختلفة Private Sub GroupHeader0_Format(Cancel As Integer, FormatCount As Integer) If X1 Then Dim ctl As Control For Each ctl In Me.Detail.Controls If ctl.ControlType = 109 Then ctl.BackStyle = 1 ctl.BackColor = 14933454 End If Next Else For Each ctl In Me.Detail.Controls If ctl.ControlType = 109 Then ctl.BackStyle = 1 ctl.BackColor = 16777215 End If Next End If X1 = Not X1 End Sub

السلام عليكم ملفك غير واضح لي لانه فارغ من بيانات الموظفين لانه من الواضح هو برنامجين في واحد ( قاعدة بيانات الموظفين+ برنامج رواتب) ممكن ان تمليء بيانات 10 موظفين كاملة تحياتي

الاستاذ الفاضل / @Abu Farid سؤال لو سمحت لى : هل انت عضو جديد ام خبير الاستشعار عندى يقول شئ تانى اخر . دعنى اتابع ردودك بعد ذلك لكى اتحقق ولو سمحت لو سمحت لا تقول لى انك طالب علم ومازلت تتعلم وانك فى اول الطريق هذه ليست محاولة منك كما قلت بل هو الحل الامثل ، نعم هذا المطلوب كيف هذا ياشيخ روح الله يعمر بيتك ويجزاك كل خير ـ ويرحم والديك دنيا وآخره ويزيدك الله علما ويعافيك في صحتك ومالك ورزقك ـ امين امين واحب ان اشكر استاذنا الفاضل / @محمد ابوعبد الله- واستاذنا / @احمد الفلاحجي واستاذنا / @alaa aboul-ela على ما قدموه لى من مساعدات ويارب يارب يجزاهم الله خير على ما يقدموه لنا كل الاحترام والتقدير لكم جميعا

الأخ hesham monzer1 ضع اسم الشيت المراد حفظها في اول سطر من الكود بدلا من ( ورقة1 ) Const Sh_Name = "ورقة1" Sub finish() ' Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Application.ScreenUpdating = False Set xWb = Application.ThisWorkbook DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = xWb.Path & "\" & xWb.Name & " " & DateString MkDir FolderName For Each xWs In xWb.Worksheets If xWs.Name = Sh_Name Then xWs.Copy If Val(Application.Version) < 12 Then FileExtStr = ".xls": FileFormatNum = -4143 Else Select Case xWb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If Application.ActiveWorkbook.HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum Application.ActiveWorkbook.Close False End If Next MsgBox "You can find the files in " & FolderName Application.ScreenUpdating = True ' End Sub

شاهد المرفقات Test_3.xls

الأخ عبدالله نبها شاهد المرفقات Test_1.rar

اشكرك استاذنا الفاضل @عبد اللطيف سلوم ما شاء الله عليك مجهود رائع تحياتي

بالاضافة الى ما تفضل به الاخوة الكرام ولهم الشكر من فضلك اخي الكريم @حلبي جرب معي الكود التالي يعمل بطريقة افضل من الاول Option Compare Database Private Sub Command1_Click() ' الشهر الحالي Dim X1, X2 As String X1 = Format(DateSerial(Year(Date), Month(Date), 1), "mm/dd/yyyy") X2 = Format(DateSerial(Year(Date), Month(Date) + 1, 0), "mm/dd/yyyy") myCriteria = "([T1].[COURSEDATE] between #" & X1 & "# and #" & X2 & "#)" Me.TSUB.Form.Filter = myCriteria Me.TSUB.Form.FilterOn = True End Sub Private Sub Command2_Click() ' الشهر السابق Dim X3, X4 As String X3 = Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm/dd/yyyy") X4 = Format(DateSerial(Year(Date), Month(Date), 0), "mm/dd/yyyy") myCriteria = "([T1].[COURSEDATE] between #" & X3 & "# and #" & X4 & "#)" Me.TSUB.Form.Filter = myCriteria Me.TSUB.Form.FilterOn = True End Sub FILTER.rar تحياتي

تفضل اخي الكريم PhotoC.rar تحياتي

اخى الفاضل عماد محاوله منى على قد حالى وهى باستخدام نموذج رئيسى مع الفرعى المستمر الرئيسى لادخال البيانات وتظهر فالنموذج المستمر مباشره ولاكن لاتستطيع التعديل على t4 لانه مغلق واعذرنى فمازلت اتعلم معكم تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق PR1.mdb

مجهود رائع

الف الف مبروك استاذ احمد الفلاحجي بالتوفيق ان شاء الله تستاهل كل خير يا طيب

Try this File My_sarch.xlsm

شاهد المرفقان Test_1.rar

بارك الله فيك وزادك الله من فضله

وعليكم السلام 🙂 عادة ما يحتاج تمسك مفتاح الشفت لتشغيل برنامجي ، ولكن ، اذا كان برنامجك فيه كود عند فتح البرنامج ، فيجب مسك مفتاح الشفت ، وعدم تركه الى ان ينتهي عمل برنامجي 🙂 جرب برنامجي على احد برامجك التي لا تحتاج الى مسك الشفت ، وبعدين جرب اللي يحتاج مسك الشفت ، واخبرنا النتيجة 🙂 جعفر

السلام عليكم شكرا لأخي الكريم egyptian_eg وأود بعد أذنه أن أنوه إلى ملحوظة مهمة جدا وهي : إن دالة Int قد تعطي نتائج لا يرغبها من لا يلم بنتائجها للقيم السالبة والأفضل أن تستخدم دالة Fix بدلا منها . نعم دالة Int في بعض اللغات الأخرى تعطي نتائج الـ Fix ولكنها هنا تحتاج إلى التدقيق بمخرجاتها ومقارنتها مع دالة Fix للتعرف على الفرق بينهما في القيم السالبة . تحياتي .

وعليكم السلام ورحمة الله وبركاته أخي/ moayad ليس لدى علم بوجود طريقة حسب ما ذكرت :$ ، ولكن يوجد لدى مثال لقاعدة بيانات تستطيع أن تضغط وتصلح وتنسخ قاعدة أخرى ، أضف إلى أنها تستطيع أن تقوم بعمل ذلك لعدة قواعد أخرى في وقت واحد تقع في مسارات مختلفة. وأعتقد أنك لو أنشئت إختصار للمثال المذكور على سطح المكتب لأستطعت أن تضغط وتأخذ نسخة إحتياطية من أي قاعدة :pp: . جرب وأخبرني أن كانت مفيده والمثال مرفق والله الموفق. Compact_Backup.rar

طبق الكود السابق هكذا On Error GoTo errsub DoCmd.Hourglass True DBEngine.CompactDatabase datapath, Backuppath, DB_LANG_ARABIC DoCmd.Hourglass False errsub: If Err.Number = 3204 Then MsgBox " A database with the same name exists in the same location ! ", 64, "Duplicate Backup Name" ElseIf Err.Number = 3356 Then MsgBox "Another user is Currently using the Database" + Chr(10) + Chr(13) + "Wait Until No Other Users are Using the Database !", 16, " Other Users WArning Message " ElseIf Err.Number = 3024 Then m = " The Database Source File : " + datapath + Chr(10) + Chr(13) + " is not available !" + Chr(10) + Chr(13) + "Please check the Source Database Name and Location" MsgBox m, 16, "Missing Data Table " ElseIf Err.Number = 3044 Then m = " Invalid File Name : " + Chr(10) + Chr(13) + "Please check the File name and location " MsgBox m, 64, "Invalid File Name " ElseIf Err.Number = 20477 Then m = " Invalid File Name : " + m3 + Chr(10) + Chr(13) + " OR " + m4 + Chr(10) + Chr(13) + " is not available !" + Chr(10) + Chr(13) + "Please check the Source Database Name and Location" MsgBox m, 64, "Invalid File Name " Else MsgBox Str(Err.Number) + Err.Description End If MsgBox "Action Canceled ! " DoCmd.Hourglass False فى زر اغلاق التطبيق

مثال آخر على النسخ الاحتياطي CopyDB2000.zip