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

استخدم هذا الكود الذي يقوم بحذف بيانات جميع الجداول ما عدا الجداول التي تحددها : ضع هذا الكود في وحدة نمطية : Function DeleteDataFromTables(excludedTables() As Variant) As String Dim obj As AccessObject, dbs As Object Set dbs = Application.CurrentData For Each obj In dbs.AllTables If Left(obj.Name, 4) <> "MSys" And Not IsInArray(obj.Name, excludedTables) Then DoCmd.SetWarnings False DoCmd.RunSQL ("DELETE * FROM " & obj.Name) DoCmd.SetWarnings True End If Next obj DeleteDataFromTables = "تم حذف سجلات جميع الجداول" End Function Function IsInArray(value As Variant, arr As Variant) As Boolean Dim element As Variant On Error Resume Next IsInArray = False For Each element In arr If element = value Then IsInArray = True Exit Function End If Next element End Function ثم يمكنك استدعاء الكود واستخدامه بالطريقة التالية : Sub ExampleUsage() Dim excludedTables() As Variant excludedTables = Array("Table1", "Table2", "Table3") ' قم بتعيين أسماء الجداول التي ترغب في استثنائها هنا Dim result As String result = DeleteDataFromTables(excludedTables) MsgBox result End Sub

وعليكم السلام ورحمة الله وبركاته 🙂 وهنا أيضا :

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل ، رابط موضوع به طلبك : . جعفر

السلام عليكم ورحمة الله نعالى وبركاته بعد ادن الاستاد أ / محمد صالح بالنسبة لاظهار بيانات اليوم فقط تفضل جرب اخي Private Sub UserForm_Initialize() Dim f As Worksheet: Set f = Sheets("ورقة1") Set d = CreateObject("scripting.dictionary") Col = f.Range("B4:E" & f.[B65000].End(xlUp).Row).Value Rng = UBound(Col, 2) With Me.ListView1 .Gridlines = True .FullRowSelect = True .View = lvwReport .ColumnHeaders.Add , , "code", 0 .ColumnHeaders.Add , , "م", 30, lvwColumnCenter .ColumnHeaders.Add , , "التاريخ", 80, lvwColumnCenter .ColumnHeaders.Add , , "اسم العميل", 120, lvwColumnCenter .ColumnHeaders.Add , , "الرقم ", 60, lvwColumnCenter Cpt = 1 ' من بداية الجدول ' For i = 1 To UBound(Col) For i = UBound(Col) - 19 To UBound(Col) ' تحديد اخر 20 صف If Col(i, 2) = Date Then ' شرط تاريخ اليوم .ListItems.Add , , Col(i, 1) For k = 1 To Rng .ListItems(Cpt).ListSubItems.Add , , Col(i, k) Next k Cpt = Cpt + 1 End If Next i End With End Sub listview 2.xlsm

تفضل اخي Option Explicit Sub FILTRE() ' فلترة البيانات بين تاريخين واسم القسم Dim i&, R, LastRow As Long, rngCell, c As Range Dim a(1 To 3) a(1) = [BK1]: a(2) = [BK2]: a(3) = [BP1] Dim MyRng As Range Dim WSdata As Worksheet: Set WSdata = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False WSdata.Range("BJ5:BY1000").ClearContents Set MyRng = WSdata.Range("AM2:BD" & WSdata.Cells(WSdata.Rows.Count, "am").End(xlUp).Row) R = MyRng For i = 1 To UBound(R) If R(i, 17) >= a(1) And R(i, 17) <= a(2) And R(i, 18) = a(3) Then WSdata.Range("BJ" & Rows.Count).End(xlUp).Offset(1).Resize(1, 16).Value _ = Array((R(i, 1)), (R(i, 2)), (R(i, 3)), (R(i, 4)), (R(i, 5)), (R(i, 6)), (R(i, 7)), (R(i, 8)), (R(i, 9)), (R(i, 10)), (R(i, 11)), (R(i, 12)), (R(i, 13)), (R(i, 14)), (R(i, 15)), (R(i, 16))) End If Next ' تسطير البيانات LastRow = WSdata.Range("BJ:BY").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSdata.Range("BJ5 :BY" & LastRow) WSdata.Range("BJ5:BY1000").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSdata.Range("BJ5:BY5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If Application.ScreenUpdating = True End Sub اظافات ممكن تفيدك للاشتغال على الملف بشكل افضل Sub CreateValidation() 'انشاء قوائم التاريخ والقسم تلقائيا بدون تكرار Dim J, K, lr As Long Dim a(1 To 2) As String Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1") lr = WSdata.Range("BC:BD").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row J = WSdata.Range("BC2:BC" & lr): K = WSdata.Range("BD2:BD" & lr) J = column(Application.Transpose(J)): a(1) = Join(J, ",") K = column(Application.Transpose(K)): a(2) = Join(K, ",") With WSdata.Range("BK1:BK2").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(1) End With With WSdata.Range("BP1").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(2) End With End Sub Function column(arr) As Variant With Application column = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _ UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False)) End With End Function وفي حدث ورقة1 انسخ الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) ' تحديث القوائم عند الاظافة او التعديل في عمود التاريخ او القسم On Error Resume Next lr = Range("BC" & Rows.Count).End(xlUp).Row If Not Intersect(Target, Range("BC2:BC" & lr)) Is Nothing Then Application.EnableEvents = False Call CreateValidation Application.EnableEvents = True Exit Sub End If ' تنفيد الكود عند التغيير في خلية القسم If Not Intersect(Target, Target.Worksheet.Range("BP1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call FILTRE Application.EnableEvents = True End If On Error GoTo 0 End Sub استخراج بالتاريخ 2.xlsm

وعليكم السلام ورحمة الله وبركاته تفضل الملف لعله يفى بالمطلوب استخراج بالتاريخ.xlsm

تفضل يا ابا البشر وانا كان فيها لزوم مالا يلزم حيث يمكن ان نصل للنتيجة بدون جداول مؤقتة واستعلام الحاق واستعلام تحديد وايضا بدون الحاجة الى انشاء استعلام بالكود كما في الطريقة على كل حال مرفق الملف حسب الطريقة الثانية وسوف اشير الى الطريقة الثالثة في رد اخر مع التأكيد ان اخونا شايب مجرد هاوي ويترك التجويد للاساتذة basey(٢)(1).accdb

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

اشكرك اخي جربت و شي جميل الله طول عمرك و جزاك الخير

كتابة اسم الشيت بها احتمالات للخطأ الأفضل اختيار الاسم من قائمة بأسماء الشيتات ساعتها يمكنك استخدام أمر فتح الشيت Sheets(Range("a1").Text).Activate بالتوفيق

نعم هذا هو المطلوب ... الخيار الثاني بيض الله وجهك ورفع قدرك ----------------------------------------------------------- اليوم رديت عليك مباشرة ولكن الآن ما لقيت الرد . وفقك الله ياعزيزي

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

بعد إذن استاذنا ، هذه تجربة بسيطة أخي @abofayez1 جرب هذا المرفق ، وضعت لك حلين ؛ انتقِ أحدهما Delete Tbl.accdb

مش عارف اقولك ايه @Foksh جزاك الله خيرا استاذي العزيز الفاضل 👍

جرب هذا التعديل أخي الكريم ، =DCount("[jop_coode]";"[data]";"([jop_coode] IN (21, 22, 26, 27, 29)) AND [jop_hala_coode]=1 AND [Insurance_coode]=1")

بارك الله فيك اخونا الشباب في فكرك والكبير قدرا .... ممكن الكود الذي اشرت اليه ( الطريقة الثانية ) للعلم والاستفادة ... جزاك الله خيرأ ..... لانه لدي كود واريد ان استفيد من تعدد الطرق ...

هل النماذج فرعية ؟؟؟؟ ام نماذج رئيسية ؟؟؟ وهل كل النماذج مفتوحة ؟؟؟ اذا كانت نماذج رئيسية وكلها مفتوحة غير في الكود بهذا الشكل ... سوف اكتب لك صيغة لعنصر واحد وانت اكمل الباقي """"" rst!ID = Forms![Form1]![T2] ال اسم النموذج الذي يوجد به ذلك العنصر( Form1 ) مع ملاحظة تغيير اسم النموذج

فرج الله همكم وحفظكم من كل سوء وسخر لكم الخير حيث ما كنتم،، على بركة الله جاري التجربة،،

مشاركة مع الاستاذ خليفه صمم التقرير المطلوب ثم اتبع الخطوات حسب الصور لديك .... ان لم تستطع اعلمنا لادراج الملف <<<<<<< Private Sub Report_Open(Cancel As Integer) Me.RecordSource = Form_fr1.SubFr.Form.RecordSource End Sub

او ... If IsNull([text1]) Then MsgBox "يجب ملء الحقل " Else DoCmd.Close End If

اليك الحل .... بالطبع أنا لم أضف عن ما قاله أستاذنا الكبير / محمد صالح الشرح داخل الملف المصنف2.xlsx

مادمت حضرتك صاحب الملف ونسيت كلمة المرور يمكنك استخدام برامج لهذا الغرض مثل AOPR Advanced office password recovery بالتوفيق

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

السلام عليكم بناءا على طلب بعض الاخوة اقدم لكم برنامج صغير لارشفة الصور برنامج ارشفه.accdb

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb

انا اعتبر نفسي مبتدء في اكسل بل اني لا افقه فيه غير الصفحة الظاهرة امامي .. فقط استخدمه كجدول حين التصدير من اكسس ومع ذلك حولت المرفق الى الاصدار 2003 والمعذرة من الجميع ان اختفى او انحذف شيء من الدالات او الأكواد مواقيت الصلاة.xlsb

بارك الله فيك وجزاك الله خيرا 🌹🌹

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

بارك الله فيك اخي