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

متألق ما شاء الله عليك أخي @hassan123 🙂 .. أفكار إبداعية جديدة 😄👌 ملاحظات وأفكار 🙂 : 1 - لاحظت أنك أدرجت ملف التحديث من ضمن الملفات ولا أضنك ستحتاج إليه بعد الآن مع التحديث الجديد 🙂 : 2 - للفائدة يمكنك الاستغناء عن الملف الذي يقوم بعملية التحديث والاستعاضة عنه بملف VBS أو ملف CMD وذلك لتجنب مشكلة الحاجة لتوثيق ملف الأكسس قبل فتحه .. فقد جربت هذه الطريقة سابقا و واجهتني مشكلة أن المستخدمين الذين لم يسبق لهم فتح ملف التحديثات ولم يتم توثيقة تقف عندهم عملية التحديث بسبب هذا الأمر .. وهذا الكود الذي أستخدمه أنا لغرض إنشاء ملف ال VBS يمكنك الاستفادة من إن أحببت 🙂 : ' Updater VBS File Path dim UpdaterFilePath UpdaterFilePath = CurrentProject.Path & "\Updater.VBS" ' ************************************************** delete Old Updater File If Len(Dir(UpdaterFilePath, vbDirectory)) > 0 Then Kill (UpdaterFilePath) End If ' ************************************************** Write The VBS File Which Updates The DB Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFile dim txtOldFEPath dim txtNewFEPath txtOldFEPath = "E:\Open DB\الملف المصدر.accdb" txtNewFEPath = "E:\Open DB\الملف الهدف.accdb" ' Creat vbs File with ANSI Coding ' الترميز الذي يدعم العربية Set oFile = FSO.CreateTextFile(UpdaterFilePath, True, False) oFile.WriteLine "Dim fs, strCopyFrom, strCopyTo" oFile.WriteLine "Set fs = CreateObject(""Scripting.FileSystemObject"")" ' Start writing The Updater File ' sleep 3 seconds oFile.WriteLine "Dim SecWait" oFile.WriteLine "SecWait = DateAdd(""s"", 3, Now())" oFile.WriteLine "Do Until (Now() = SecWait)" oFile.WriteLine "Loop" ' copy files oFile.WriteLine "strCopyFrom = " & """" & txtNewFEPath & """" oFile.WriteLine "strCopyTo = " & """" & txtOldFEPath & """" oFile.WriteLine "fs.CopyFile strCopyFrom, strCopyTo, True" ' open the new version oFile.WriteLine "CreateObject(""Shell.Application"").Namespace(0).ParseName(strCopyTo).InvokeVerb ""Open""" oFile.WriteLine "Set fs = Nothing" oFile.Close Set FSO = Nothing Set oFile = Nothing ' ************************************************** Open the VBS Updater File Shell "explorer.exe" & " " & UpdaterFilePath, vbMinimizedNoFocus ' ************************************************** Close FE Database Application.Quit 3- أزيدك من الشعر بيت 😄 .. هذا كود لإضافة ملف التحديثات الجديدة لحقل المرفقات في الجدول بطريقة سهلة ( يفتح مستعرض الملفات >> تختار ملف التحديث >> وتم بحمد الله ) 🙂 Option Compare Database Option Explicit Public Sub AddAttacmentToTable(TableName As String, AttachmentFieldName As String, IDField As String, IDvalue As Long) 'TableName = اسم الجدول 'AttachmentFieldName = اسم حقل المرفقات 'IDField = اسم حقل الآيدي 'IDvalue = رقم الآيدي On Error GoTo HandleError Dim db As DAO.Database Dim rs As DAO.Recordset Dim attachFld As DAO.Recordset Dim file As String file = selectFile Set db = CurrentDb Set rs = db.OpenRecordset("select * from " & TableName & " where " & IDField & " = " & IDvalue & ";") ' Or OpenRecordset("TableName") ' Debug.Print "select * from " & TableName & " where " & IDField & " = " & IDvalue & ";" If Not rs.BOF And Not rs.EOF Then rs.MoveFirst rs.Edit Set attachFld = rs.Fields(AttachmentFieldName).Value attachFld.AddNew attachFld.Fields("FileData").LoadFromFile file attachFld.Update rs.Update End If MsgBox "done" rs.Close Set db = Nothing Set rs = Nothing HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Exit Sub Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description End If Resume HandleExit End Sub Public Function selectFile() ' دالة مستعرض الملفات On Error GoTo ErrHandler Dim fd As Object Dim filedialogPath As String Set fd = Application.FileDialog(1) fd.AllowMultiSelect = False fd.Title = "حدد الملف المطلوب" ' fd.InitialFileName = CurrentProject.Path fd.Filters.Clear fd.Filters.Add "كل الملفات", "*.*" If fd.Show = True Then selectFile = fd.SelectedItems(1) ' Exit Function Else MsgBox "لم تقم باختيار أي ملف" Exit Function End If ErrHandler: If Err.Number = 0 Then Exit Function Else MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description ' End If End Function Sub testing() 'للتجربة AddAttacmentToTable "att", "Att_T", "ID", 4 End Sub مع تمنياتي لك بالتوفيق 🙂

وعليكم السلام ورحمة الله نعالى وبركاته اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار لنفترض ان الخلية المحددة هي (R1) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub بطريقة اخرى Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub صفحة الرصد V2.xlsm

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹

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

مشاركة مع الأستاذ @محمد احمد لطفى .. اخي الكريم الأخطاء بسيطة ، فمثلاً الأمر Exit Sub يجب وضعها قبل اغلاق الجملة الشرطية لا بعدها ، ثم جملة فتح النموذج غير صحيحة والصحيح يصبح كالآتي :- If Me.aa = 1 Then GoTo oo Else MsgBox "يجب كتابة رقم صحيح" Exit Sub End If oo: DoCmd.OpenForm "bb" End Sub لاحظ الفروقات لتتضح الصورة عندك 😊

بعد اذنك نكمل غداً تكون قرأت وجربت وحددت طلباتك . رمضان كريم .

تغيير تاريخ الصلاحية (123) والبرنامج الرئيسي (User :mahdi Pass :1960)

الى أخي وأستاذي @abouelhassan هديتي لك وللمنتدى . يارب تعجبك . اقرأ ما بالتكست (اقرأني جيدا) وأكمل الباقي وانشاء الله أنا معك بأي استفسار . BOTARIQPermissions.rar

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

استاذنا @abouelhassan كان بدي ارسل لك الأداة كاملة ولكنها لاتعمل بدون تفعيل وأنا بشترك بها سنوياً وليس لها كراك عندي ..فإذا مهتم بإقتنائها تفضل . accessfixinstaller.rar

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

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

رابط الموقع الرسمي

اشكرك استاذي الكريم @Moosak على الاضافة الجميلة والهامة ☺️

اشكرك على هذا التعليق اختنا @Lamyaa ، لكن الكود الذي ادرجته وجب ان يتحقق من عدد القيم في الباركود اضافة الى ذلك انه يتعامل مع القيم الفارغة في أحد خانات القراءة التي تم بناء الـ QR عليها . وفعلاً كود حضرتك يحقق نفس الغاية تقريباً 😊

تفضل أستاذ @al.sheen2000 محاولتي حسب مافهمت . اليك المرفق . ووافني بالرد . واذا كان هذا طلبك لا تنسى الضغط على افضل اجابة . المنتدى (2).rar

جرب الملف دا وشوف التعديل ترحيل بالتاريخ 33.xlsx

السلام عليكم الاخ مازن بياناتك عبارة عن اعمدة ونحن بحاجة الى عرضها بشكل افقي انظر الى العمل بالترتيب خطوة خطوة كما ابينه بالشرح لك ، من اجل تفهم طريقة العمل 1- استعلام query1 تم فيه تجميع الحالات حسب الرتبة 2- استعلام جدولي لنشر البيانات وتوزيعها مصدره query1 وبما ان الاستعلام الجدولي صامت لا يمكن التعامل مع حقوله عند العرض استخدمنا جدول مؤقت وسيط يكون هو المصدر الاساسي للتقرير حيث يتم الحق بيانات الاستعلام الجدولي اليه بين فترة واخرى كلما تغيرت او زادت البيانات باستخدام زر ( اعداد التقرير ) لم افهم ما تعني بالمجموع الفعلي والمجموع الكلي لذا تركته لك يمكنك عمله بكل يسر --------------------------------------------------------- انا عملت على عرض جميع الحالات بالتفصيل ويمكنك ضم بعض الحالات مع بعضها افتح التقرير على التصميم وفي الخصائص انقر على النقاط الثلاث في مصدر بيانات التقرير سيعرض لك الاستعلام المصدر الذي يمكنك من خلاله اجراء جميع التعديلات كإنشاء حقول تجميع وضم بعضها الى بعض او حذف ما لا تريده . آمل ان يروق العمل لك قاعدة2.rar

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل أخي @العبيدي رعد لا تظهر بيانات إلا من كان في ذمته شيء .. الكود يكتب في الحدث فورمات للمجموعة أو التقسيمة : الكود : القروض 10.rar

استاذ @سيد تيمي. حاول ترسل القاعدة

السلام عليكم اعضاء الكنترول الكرام اضع بين ايديكم شيت كنترول جدارات _ قسم حاسبات " الصف الاول "_ مفتوح المصدر يشتمل على ♦ شيت الرصد ♦ شهادات التيرم الاول ♦ شهادات نهاية العام ♦ تحديد الاوائل في الشهادة " هذا العمل خالصا لوجه الله تعالى " hasbat_1_gdarat.xlsm

السلام عليكم السادة الكرام اعضاء المنتدى المطلوب لو 7 أيام يكتب انذار اول ولو 14 انذار تانى ولو 21 انذار ثالث ولو 28 انذار رابع ولو اكتر من 30 قرار فصل تسجيل الحضور والغياب.xlsx

تفضل تسجيل الحضور والغياب.xlsx

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

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

Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar

السلام عليكم ورحمة الله استخدم هذا الكود Sub Tarhil() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim Setlt As String Set ws = Sheets("كشف السداد") Set Sh = Sheets("حساب العملاء") Setlt = "تم السداد" LR = ws.Range("B" & Rows.Count).End(xlUp).Row Arr = ws.Range("B5:F" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 5) = Setlt Then p = p + 1 For j = 1 To 4 Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5)) Next End If Next If p > 0 Then Sh.Range("B4").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

جرب التعديل التالي عله يفي بالغرض (ويرجى فيما بعد حين تطرح موضوع أن ترفق الملف الأصلي أو ملف معبر عنه تماماً لكي يسير العمل بشكل منتظم وكما هو مطلوب ومتوقع) Sub Test() Dim arr As Variant Dim arBr As Variant Dim arLu As Variant Dim arDi As Variant Dim i As Long Dim j As Long Dim b As Long Dim l As Long Dim d As Long arr = Range("A116:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim arBr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arLu(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arDi(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) For i = 1 To UBound(arr, 1) If arr(i, 4) = "ص" Then b = b + 1 For j = 1 To 3 arBr(b, j) = arr(i, j) Next j arBr(b, 4) = arBr(b, 2) * arBr(b, 3) ElseIf arr(i, 4) = "غ" Then l = l + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) Next j arLu(l, 4) = arLu(l, 2) * arLu(l, 3) ElseIf arr(i, 4) = "ع" Then d = d + 1 For j = 1 To 3 arDi(d, j) = arr(i, j) Next j arDi(d, 4) = arDi(d, 2) * arDi(d, 3) ElseIf arr(i, 4) = "م" Then l = l + 1 d = d + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) arDi(d, j) = arr(i, j) Next j arLu(l, 2) = Application.WorksheetFunction.Round(arLu(l, 2) * 2 / 3, 2) arDi(d, 2) = Application.WorksheetFunction.Round(arDi(d, 2) * 1 / 3, 2) arLu(l, 4) = arLu(l, 2) * arLu(l, 3) arDi(d, 4) = arDi(d, 2) * arDi(d, 3) End If Next i Range("B15").Resize(b, UBound(arBr, 2)).Value = arBr Range("B24").Resize(l, UBound(arLu, 2)).Value = arLu Range("B65").Resize(d, UBound(arDi, 2)).Value = arDi End Sub

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله