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

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

السلام عليكم ورحمة الله تفضل المعادلة في الملف المرفق... بن علية Demo222.rar

فهمك للكود ممتاز هذا هو المغز بالضبط من وضع * في مربع النص

والله ما شفت شرح اجمل من هذا الشرح ببساطته ويسره ادركت الان لماذا توجد علامة * في داخل مربع نص كود سكول وذلك لجلب النتائج كاملة لجميع الادارات اذا كانت القائمة المنسدلة للادارات فارغة اما اذا كانت القائمة المنسدلة للادارات مشغولة فهو يأتي بجميع النتائج لهذه الادارة فقط هل فهمي للكود بهذه الطريقة صحيح ؟

الله يعطيك العافيه جميل جدا

السلام عليكم و رحمة الله تعالى و بركاته. أخي الأستاذ محمد أيمن بعد إذنك أريد المشاركة معكم في هذا الموضوع: يمكن أيضا تنفيذ البحث عن ملف داخل الجهاز بهذا الكود: If Dir("D:\1.txt") = "" Then MsgBox "عذرا ملف الحماية غير موجود", vbCritical Quit End If

نعم أخي تفضل الشرح: Me.codeschoole = "*" هذا الكود في حدث بعد التحديث لقائمة الإدارة فعند اختيار عنصر من القائمة يقوم الكود بإفراغ باقي القوائم و يكتب داخل مربع نص codeschoole نجمة (*). و لقد كتبت في الإستعلام هذا الكود Like [Forms]![tsform]![codeschoole] مع العلم أن هذا الكود يقوم بإعطائك النتائج كاملة إذا كانت قيمة مربع النص هي (*). If IsNull(Me.codeschoole) Then Me.codeschoole = "*" End If Me.fform.Requery و هذا الكود في حدث بعد التحديث لمربع النص codeschoole يقوم بكتابة (*) داخل مربع النص إذا قمت بحذف محتواه من الأرقام. إن شاء الله نكون قد وفقنا في الشرح و الله هو المستعان. شكرا جزيلا أستاذ محمد

جزاك الله خيرا ياملك المعادلات

السلام عليكم نعم بالفعل ، هناك تعديل لاحق

استاذ صالح بسم الله ما شاء الله حل رائع

استعمل هذا الكود Dsum("Quantity","fatora","id2='" & [رقم العميل] & "'")

مشاركة مع إخوتي و أساتذتي الكرام تفضل ربما هذا ما تبحث عنه تصفية بواسطة كومبو بوكس رقم 1.rar

استبدل الى هذا الماكرو Sub TekrarList_With_choise() Application.ScreenUpdating = False Dim x As Long Dim dictionary As Object Dim my_rg As Range Dim My_number As Integer My_number = ActiveSheet.[f1] If Not IsNumeric(My_number) Or My_number <= 0 Then Exit Sub Else My_number = Int(My_number) End If If My_number = 0 Then My_number = 1 Set dictionary = CreateObject("scripting.dictionary") Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown)) ActiveSheet.Range("b:d").ClearContents Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة" On Error Resume Next For i = 1 To my_rg.Count x = Application.CountIf(my_rg, my_rg.Cells(i)) If My_number >= my_rg.Count Then Exit Sub If x >= My_number Then dictionary.Add my_rg.Cells(i).Value, 1 End If Next Sheets(1).Range("d2") = dictionary.Count Sheets(1).Range("b2").Resize(dictionary.Count).Value = _ Application.Transpose(dictionary.keys) For m = 1 To dictionary.Count ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2)) Next Application.ScreenUpdating = True End Sub

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

أو يمكن كتابة المعادلتين التاليتين =SUMPRODUCT(--($H$3:$H$29="ثانوي ")) =SUMPRODUCT(--($H$3:$H$29="متوسط"))

جرب هذا الماكرو Sub TekrarList() Application.ScreenUpdating = False Dim x As Long Dim dictionary As Object Dim my_rg As Range Set dictionary = CreateObject("scripting.dictionary") Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown)) ActiveSheet.Range("b:d").ClearContents Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة" On Error Resume Next For i = 1 To my_rg.Count x = Application.CountIf(my_rg, my_rg.Cells(i)) If x >= 10 Then dictionary.Add my_rg.Cells(i).Value, 1 End If Next Sheets(1).Range("d2") = dictionary.Count Sheets(1).Range("b2").Resize(dictionary.Count).Value = _ Application.Transpose(dictionary.keys) For m = 1 To dictionary.Count ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2)) Next Application.ScreenUpdating = True End Sub

اسف على قلة شرحي الاول العجب كله يرجع لهذه وحدة نمطية اللي بها فانكشن باسم ConvertColumnToRow وفي الاستعلام راح نستخدم هذا الاسم Public Function ConvertColumnToRow(strField As String, _ strTable As String, _ Optional strWhere As String, _ Optional strOrderBy As String, _ Optional strSeparator = ", ") As Variant On Error GoTo Err_Handler Dim rs As DAO.Recordset Dim rsMV As DAO.Recordset Dim strSql As String Dim strOut As String Dim lngLen As Long Dim bIsMultiValue As Boolean ConvertColumnToRow = Null strSql = "SELECT " & strField & " FROM " & strTable If strWhere <> vbNullString Then strSql = strSql & " WHERE " & strWhere End If If strOrderBy <> vbNullString Then strSql = strSql & " ORDER BY " & strOrderBy End If Set rs = DBEngine(0)(0).OpenRecordset(strSql, dbOpenDynaset) bIsMultiValue = (rs(0).Type > 100) Do While Not rs.EOF If bIsMultiValue Then Set rsMV = rs(0).Value Do While Not rsMV.EOF If Not IsNull(rsMV(0)) Then strOut = strOut & rsMV(0) & strSeparator End If rsMV.MoveNext Loop Set rsMV = Nothing ElseIf Not IsNull(rs(0)) Then strOut = strOut & rs(0) & strSeparator End If rs.MoveNext Loop rs.Close lngLen = Len(strOut) - Len(strSeparator) If lngLen > 0 Then ConvertColumnToRow = Left(strOut, lngLen) End If Exit_Handler: Set rsMV = Nothing Set rs = Nothing Exit Function Err_Handler: MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ConvertColumnToRow()" Resume Exit_Handler End Function وبعدين عملنا استعلام كما مبينة بالصور وبعدين عملنا تقرير على هذا الاستعلام وحفظنا التقرير باسم Query1 وبعد عملنا تقرير على هذا الاستعلام اي يعني مصدر هذا التقرير هو استعلام Query1 كما مبينة في الصورة وفي النهاية النتيجة طلعت هكذا مع تقدير

جهد جبار ومرتب ومنظم وسهل الاستخدام والتدريب لغة مفهومه شرح وافي وكتاب في تخصصه كافي شكرا لك استاذنا العزيز لا تحرمنا من ابدعاتك طابت ايامك دمت بود

تفضل اخي الكريم لعله المطلوب xlfdic04.zip

زادك الله من علمه وشرح صدرك ويسر أمرك أخى وأستاذى ناصر سعيد

تفضل اخي الكريم الملف في المثال هو ملف نصي txt اسم الملف 1 قم بانشاء ملف نصي باسم (1) و ضعه في القرص D طبعا يمكنك تعديل الكود كما ترغب db2017.rar