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

ضع ازرار لضغط و اصلاح قاعدة البيانات و ضع فيه الكود التالي Dim vbscrPath As String vbscrPath = CurrentProject.Path & "\CRHelper.vbs" If Dir(CurrentProject.Path & "\CRHelper.vbs") <> "" Then Kill CurrentProject.Path & "\CRHelper.vbs" End If Dim vbStr As String vbStr = "dbName = """ & CurrentProject.FullName & """" & vbCrLf & _ "resumeFunction = ""ResumeBatch""" & vbCrLf & _ "Set app = CreateObject(""Access.Application"")" & vbCrLf & _ "Set dbe = app.DBEngine" & vbCrLf & _ "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _ "On Error Resume Next" & vbCrLf & _ "Do" & vbCrLf & _ "If Err.Number <> 0 Then Err.Clear" & vbCrLf & _ "WScript.Sleep 500" & vbCrLf & _ "dbe.CompactDatabase dbName, dbName & ""_1""" & vbCrLf & _ "errCount = errCount + 1" & vbCrLf & _ "Loop While err.Number <> 0 And errCount < 100" & vbCrLf & _ "If errCount < 100 Then" & vbCrLf & _ "objFSO.DeleteFile dbName" & vbCrLf & _ "objFSO.MoveFile dbName & ""_1"", dbName" & vbCrLf & _ "app.OpenCurrentDatabase dbName" & vbCrLf & _ "app.UserControl = True" & vbCrLf & _ "app.Run resumeFunction" & vbCrLf & _ "End If" & vbCrLf & _ "objFSO.DeleteFile Wscript.ScriptFullName" & vbCrLf Dim fileHandle As Long fileHandle = FreeFile Open vbscrPath For Output As #fileHandle Print #fileHandle, vbStr Close #fileHandle Dim wsh As Object Set wsh = CreateObject("WScript.Shell") wsh.Run """" & vbscrPath & """" Set wsh = Nothing Application.Quit

السلام عليكم إخواني الأعزاء .. ومع الدرس الثاني من سلسلة مهارات في أكسس .. صندوق قائمة لتعديل البيانات List Box آرائكم وتوجيهاتكم هي خير ما تتفضلون به علي .. متمنيا لكم دوام التوفيق .. مشاهدة ممتعة أتمناها لكم .. ‏‏ListBox - Lesson.accdb

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

تفضل هذا التعديل و اضف الجداول التي تحتاجها Dim strPath As String strPath = Me.txtPath Dim FrontObj As AccessObject, FrontDB As Object Set FrontDB = Application.CurrentData For Each FrontObj In FrontDB.AllTables If Left(FrontObj.Name, 4) <> "MSys" And FrontObj.Name <> "ccc" And FrontObj.Name <> "eee" Then DoCmd.DeleteObject acTable, FrontObj.Name End If Next FrontObj Dim BackObj As DAO.TableDef, BackDB As DAO.Database Set BackDB = DBEngine.Workspaces(0).OpenDatabase(strPath, True, False) For Each BackObj In BackDB.TableDefs If Left(BackObj.Name, 4) <> "MSys" And BackObj.Name <> "ccc" And BackObj.Name <> "eee" Then If BackObj.Name = "الجدول الأول" _ Or BackObj.Name = "الجدول الثاني" _ Or BackObj.Name = "الجدول الثالث" _ Or BackObj.Name = "الجدول الرابع" Then DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, BackObj.Name, BackObj.Name End If End If Next BackObj Set FrontDB = Nothing Set BackDB = Nothing

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

تفضل هذا التعديل قد يفي بالغرض Usrse.zip

شكر وتقدير واحترام من اخيك

السلام عليكم 🙂 ليش يا جماعة المراسلة بالايميل (مخالف لقوانين المنتدى) ، ضع كل شيء هنا حتى يستفيد الجميع 🙂 جعفر

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

جرب كده المستخدم ناقل باس 123 Usrse1.accdb

نعم ممكن : 1. عمل جدول جديد فارغ فيه جميع حقول جدولك الحالي ، باسم New_Tab ، 2. عمل استعلام اضافة سجلات ، من الجدول القديم الى الجدول الجديد ، 3. اضافة جميع سجلات الجدول القديم باستثاء الحقل ID ، عمل الفرز بالحقل TNO ، INSERT INTO New_TAB ( TNO, Auto_Date, File_Name, nom, MNO, NASS, Col_3, TYPE1, TYPE2, TFLVL, TFR, MUSND, TR, MOVEX ) SELECT TAB.TNO, TAB.Auto_Date, TAB.File_Name, TAB.nom, TAB.MNO, TAB.NASS, TAB.Col_3, TAB.TYPE1, TAB.TYPE2, TAB.TFLVL, TAB.TFR, TAB.MUSND, TAB.TR, TAB.MOVEX FROM TAB ORDER BY TAB.TNO; 4. تنفيذ الاستعلام 🙂 جعفر

أ / محمد صالح جزاكم الله خيرا؛ طبقت المعادلة وفعلا نجحت معي؛ لكم خالص الشكر والتقدير

وعليكم السلام 🙂 الترقيم التلقائي يكون بحسب تسلسل عمل السجلات ، ولا علاقة له بطريقة الفرز والتصفية في الجدول ، يعني ، سواء عملت حقل الرقم التلقائي عند عمل الجدول ، او عملته بعد سنه ، فالرقم التلقائي سيكون نفسه ، طبعا بالاخذ في الاعتبار السجلات المحذوفة والتي سيتجاهلها ويعمل التسلسل. جعفر

عاشت الايادي استاذ موسى

كل الشكـــــــر والتقدير

يمكنك استعمال هذه المعادلة =NETWORKDAYS.INTL(A2,EOMONTH(A2,0),"1111011") مع وضع تاريخ بداية الشهر المطلوب في الخلية A2 بالتوفيق

تفضل ....... ابا الحسن ... استيراد_ناقل.accdb

ارفق القاعدة رجاء

وعليكم السلام ضع هذا في حدث الحالي مثلا ..... مربع البحث a Me.a.SetFocus

تفضل هذا التعديل On Error Resume Next Dim strPath As String strPath = Me.txtPath Dim FrontObj As AccessObject, FrontDB As Object Set FrontDB = Application.CurrentData For Each FrontObj In FrontDB.AllTables If Left(FrontObj.Name, 4) <> "MSys" And FrontObj.Name <> "ccc" And FrontObj.Name <> "eee" Then DoCmd.DeleteObject acTable, FrontObj.Name End If Next FrontObj Dim BackObj As TableDef, BackDB As Database Set BackDB = DBEngine.Workspaces(0).OpenDatabase(strPath, True, False) For Each BackObj In BackDB.TableDefs If Left(BackObj.Name, 4) <> "MSys" And BackObj.Name <> "ccc" And BackObj.Name <> "eee" Then If BackObj.Name = "aaa" _ Or BackObj.Name = "bbb" _ Or BackObj.Name = "ccc" Then DoCmd.RunSQL "DROP TABLE [" & BackObj.Name & "]" DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, BackObj.Name, BackObj.Name End If End If Next BackObj Set FrontDB = Nothing Set BackDB = Nothing

وفقك الله وحفظكم شكرا لكم لكم وافر احترامي اخي العزيز

استبدل السطر كامل بالتالي Dim BackObj As DAO.TableDef, BackDB As DAO.Database

تم انشاء نسخة مماثلة من الجدول المرتبط بالنموذج الفرعي و تم ربط النسخة mainData_NonSave بالنموذج الفرعي و تم انشاء استعلام الحاقي لكي يتم اخذ جميع السجلات من النسخة الجديدة و الحاقها بالجدول الرئيسي و افراغ الجدول بعد الإلحاق If DCount("*", "mainData_NonSave") = 0 Then MsgBox "لا توجد بيانات لترحيلها", vbCritical + vbMsgBoxRight, "تنبيه" Else If MsgBox("هل تريد حفظ البيانات و ترحيلها ؟", vbExclamation + vbYesNo + vbMsgBoxRight, "تأكيد الحفظ") = vbYes Then DoCmd.SetWarnings False DoCmd.OpenQuery "AddNew_minData" '================ تشغيل الاستعلام الإلحاقي =============== DoCmd.RunSQL "DELETE FROM mainData_NonSave;" '============== افراغ الجدول المؤقت من البيانات بعد تشغيل الاستعلام الالحاقي ========== DoCmd.SetWarnings True mainData.Requery MsgBox "تم حفظ البيانات و ترحيلها بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" End If End If

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) a = ws.Range("B6:M" & ws.Cells(Rows.Count, "C").End(xlUp).Row).Value a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,6,9,10,11,12}]) 'first empty row (new line added) m = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 'change 7 in the following two lines to use the variable m instead sh.Range("A" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a sh.Range("I" & m).Resize(UBound(a, 1)).Value = ws.Range("C4").Value Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته غالبا المشكلة في كود فتح الملف ويمكن استبدال الكود بالتالي Dim fpathz As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Clear .Filters.Add "All Files", "*.*" .Filters.Add "jAccess Files", "*.mdb" .Filters.Add "Access Files", "*.Accdb" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then fpathz = .SelectedItems(1) Me.txtPath = fpathz End If End With استيراد جدول.rar تحياتي

هذا الكود لا يتناسب السجلات المتعددة فقط للسجلات الفردية لكني تفضلي هذا الإسلوب في تخزين و ترحيل البيانات بين الجداول حيث تم انشاء نسخة مطابقة للجدول لحفظ البيانات المؤقته فيه و من ثم يتم ترحيلها للجدول الأساسي تفضلي التعديل test.zip

ممكن نسخة 2003 حتى نشوف هذا الروائع اخى الكريم

روائع تحفظ فى العين تسلم ايدك استاذى

بارك الله في جهدك وعلمك ووقتك وعمرك أستاذنا العزيز ... ألاحظ فيك الإخلاص في كل ما تقوم به .. أسأل الله لك التوفيق

😂 عذرا لم الاحظ ذلك

الحمد لله الذي بنعمته تتم الصالحات

اخى نزل الملف مره اخرى تم تعديله او انسخ الكود مره اخرى Sub Test() Dim SH As Worksheet, WS As Worksheet, SHLR As Long, WSLR As Long, CEL As Range Application.DisplayAlerts = False Application.EnableEvents = False Set WS = ThisWorkbook.Worksheets("Total") For Each SH In Worksheets If SH.Name <> "Total" Then With SH SHLR = SH.Cells(Rows.Count, 4).End(xlUp).Row + 1 For Each CEL In SH.Range("D14:D" & SHLR) If CEL.Value <> Empty Then WSLR = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row + 1 WS.Range("A" & WSLR) = SH.Range("I14") WS.Range("B" & WSLR) = SH.Range("L14") WS.Range("C" & WSLR) = CEL.Value End If Next CEL End With End If Next SH Application.DisplayAlerts = True Application.EnableEvents = True End Sub

بعد ما تنسخ الكود اضغط على f5 ليتم تشغيله او اعمل زر انظر للمشاركه السابقه اخى الكريم حمل الملف المرفق مره اخرى

مساء الخير جرب الملف المرفق وجرب تدخل شيت جديد ببيانات جديدة وبعدين روح لشيت اسم Query1 واعمل تحديث عالجدول الاخضر كليك يمين تحديث او من فوق من Query تضغط تحديث ملاحظة حاول دائما تستخدم الجداول لتسهيل عملية البرمجة والبحث ارجو ان يكون الملف هو ما طلبت دمج.xlsx

Sub Print6() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name = "Sheet1" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then ws.Range("A1:K" & ws.Cells(Rows.Count, "B").End(xlUp).Row).PrintOut End If Next End Sub

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

يمكنك استعمال هذا الإجراء Sub mas() lr = Cells(Rows.Count, 3).End(3).Row With Range("d4:d" & lr) .Formula = "=IFERROR(VLOOKUP(C4,H$4:I$27,2,0),"""")" .Value = .Value End With MsgBox "Done by mr-mas.com" End Sub وربطه يزر أو في حدث التغيير بالتوفيق

الأسهل تصدير الملف بصيغة xlsx أو csv من خادم قاعدة البيانات ويمكن استعمال هذه الصفحة لتحويل الملف إلى اكسل https://www.convertcsv.com/sql-to-csv.htm بالتوفيق

أستاذنا العزيز .. جربت تشغيل الملف على نسخة الأكسس 365 ولم تعمل .. ! هل لرقم الإصدار دخل في ذلك ؟