Foksh

بداية ، كل العذر منك ، فقد اختلطت علي الأمور قليلاً بين هنا وهناك ، والحق أحق أنني قد تسرعت دون تركيز مني . أهلا أستاذنا الفاضل @عبدالله بشير عبدالله ، وقد تشرفت بالتعرف على نخبة من عمالقة الإكسل وأنت أحدها طبعاً ( ولا غنى بقية الأخوة والأساتذة والمعلمين ) ، وتطرقي الى اكسل في الفترة الأخيرة لهو نابع من فقري الى الممارسة في برمجة اكسل والتعمق فيه بشكل قوي ، فمعلوماتي وخبرتي فيه ليست بحجم خبرتكم ومعلوماتكم هنا في قسمكم أخي الفاضل . وطبعاً لن أزايد على كود الأستاذ @عبدالله بشير عبدالله ، لأنه احترافي بشكل فعال أكثر من فكرتي كنت سأطرحها ، حيث انه يستخدم مصفوفة dataArray لمعالجة البيانات في الذاكرة ( أسرع بكثير من فكرتي التي خطرت لي ) ، والعديد من الميزات في اقتراحه أفضل بكثير . ويسعدني المتابعة معكم والإستفادة من خبرة الأساتذة هنا

أخي جو ، اعذرني على مداخلتي ، ولكن الصورة غير واضحة ، وكأنها كانت مجرد رفع عتب أنك قمت بالتوضيح بشكل غير واضح !!! ثانياً ، PCode = 40 في الجدول Tbl_Lab_All ، يمثل السجل "هاجر عشرى على" على سبيل المثال . فكيف تريد تحديث القيمة لباقي السجلات , ولكن تبين لي أن الرابط فيما بينهم هو حقل التاريخ إن لم أكن مخطئاً ، صحيح ؟ وعليه فبعد تتبع تنسيق التاريخ في الجدول Tbl_Lab_Requests في الحقل Date_R ، كان التاريخ بالتنسيق "2025-01-12" بينما في النموذج في مربع النص DDate = 12,January,2025 ، أي أن التنسيق مختلف في حال قمنا بتحديد التاريخ كشرط للسجلات التي تتبع نفس التاريخ للتحديث . انظر ماذا تستطيع فعله لتلافي هذه المشكلة في تصميمك لمشروعك .

السبب أن الاستعلام يستخدم القيمة من النموذج الرئيسي ([Forms]![Laboratory]![id]) ، بينما السجلات التي تريد تحديثها موجودة في النموذج الفرعي المستمر ، أي أن هناك عدة سجلات بنفس PCode ، لكن التحديث يستهدف سجلًا واحداً فقط . ويجب أن تأخذ قيمة المفتاح (PCode) من السجل الحالي في النموذج الفرعي ، وليس من النموذج الرئيسي . لذا جرب هذا التعديل ، رغم انك تعلم جيداً ضرورة ارفاق ملف في معظم الطلبات والاستفسارات.. DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET R_External_lab = 'المختبر' " & _ "WHERE PCode = " & Forms!Frm_Main!Frm_Sub.Form!PCode & ";" فقط تأكد من اسم نموذج الفرعي والرئيسي اخي الكريم ..

اهلا اخي الكريم 🤗 الأمر بسيط بإذن الله تعالى ، في المكان الذي تكتب فيه رسالتك او موضوعك أو ردك ، يوجد زر <> هذا الزر وظيفته لكتابة الأكواد التي تود مشاركتها معنا ، جربه وستجد الموضوع بتنسيق ونمط جميلين في ردودك لاحقاً.

اخي الكريم @jo_2010 ، ارفق الكود مكتوب وليس صورة اذا تكرمت .

ولا يهمك اخي الكريم ، خذ راحتك ، واليوم فعلاً انا خارج المنزل وبعيد عن الكمبيوتر الى صباح غد إن شاء الله 🤗😇

وعليكم السلام ورحمة الله وبركاته ،، باعتقادي ما ينطبق على اكسيس يمكن ان ينطبق على اكسل . فأولاً يلزمك تثبيت مكتبة SDK منموقع الشركة ZKTeco من هذه الصفحة هنا ( يلزمك تسجيل الدخول طبعاً للتحميل من الموقع الرسمي ) . حيث انها تحتوي على مكتبة الوظائف التي تسمح بالاتصال المباشر بالجهاز . بعد تحميل البرنامج من الموقع الرسمي ، قم بتسجيل المكتبة zkemkeeper.dll كما يلي :- افتح موجه الأوامر CMD كمسؤول ، ثم استخدم السطر التالي مع تعديل مسار الملف السابق حسب مسار التثبيت لديك :- regsvr32 "C:\المسار\zkemkeeper.dll" ثم قم بإضافة المكتبة بحيث أن تفعّل خيار: zkemkeeper.dll أو ZKEMkeeper 1.0 Type Library الآن كود VBA بسيط للاتصال بالجهاز :- Dim zk As New zkemkeeper.CZKEM Sub ConnectToDevice() Dim connected As Boolean connected = zk.Connect_Net("192.168.1.201", 4370) If connected Then MsgBox "تم الاتصال بالجهاز بنجاح" Else MsgBox "فشل الاتصال بالجهاز" End If End Sub تأكد من عنوان IP الخاص بالجهاز طبعاً . وهذه دالة لجلب سجلات الحضور :- Option Explicit Dim zk As New zkemkeeper.CZKEM Sub GetAttendanceLogs() Dim ip As String: ip = "192.168.1.201" ' لجهاز البصمة لديك IP غيّر هذا العنوان إلى عنوان Dim port As Long: port = 4370 ' المنفذ الافتراضي عادةً Dim iMachineNumber As Long: iMachineNumber = 1 Dim connected As Boolean connected = zk.Connect_Net(ip, port) If Not connected Then MsgBox "فشل الاتصال بالجهاز. تحقق من الشبكة أو الإعدادات", vbCritical Exit Sub End If zk.EnableDevice iMachineNumber, False If Not zk.ReadGeneralLogData(iMachineNumber) Then MsgBox "لا توجد سجلات متاحة ، أو تعذر قراءتها", vbExclamation zk.EnableDevice iMachineNumber, True zk.Disconnect Exit Sub End If Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") ws.Cells.ClearContents ws.Range("A1:E1").Value = Array("UserID", "DateTime", "State", "Verified", "WorkCode") Dim userID As Long, verifyMode As Long, inOutMode As Long Dim year As Long, month As Long, day As Long Dim hour As Long, minute As Long, second As Long Dim workCode As Long Dim row As Long: row = 2 Do While zk.SSR_GetGeneralLogData(iMachineNumber, CStr(userID), _ verifyMode, inOutMode, year, month, day, hour, minute, second, workCode) Dim dt As String dt = Format(DateSerial(year, month, day) + TimeSerial(hour, minute, second), "yyyy-mm-dd hh:nn:ss") ws.Cells(row, 1).Value = userID ws.Cells(row, 2).Value = dt ws.Cells(row, 3).Value = inOutMode ws.Cells(row, 4).Value = verifyMode ws.Cells(row, 5).Value = workCode row = row + 1 Loop zk.EnableDevice iMachineNumber, True zk.Disconnect MsgBox " تم سحب عدد " & row - 2 & " من سجلات الحضور بنجاح", vbInformation End Sub شرح الأعمدة :- UserID = رقم الموظف DateTime = تاريخ ووقت الحضور/الانصراف State = نوع الحركة (0 = دخول ، 1 = خروج) Verified = طريقة التحقق (بصمة ، كارت ، كلمة مرور) WorkCode = رمز العمل (اختياري ، حيث يعتمد على الجهاز) هذا من وجهة نظري بعد التعديل فيما يتوافق مع اكسل ( مشتق من أكواد آكسيس ) ولكم التجربة طبعاً لأنني حالياً لا أملك جهاز البصمة المذكور نوعه سابقاً ..

وعليكم السلام ورحمة الله وبركاته ،، جرب أخي هذا التعديل !! Sub ترحيل_المعاش_ق() Dim wsSource As Worksheet, wsTarget As Worksheet, wsNew As Worksheet Dim sourceData As Variant, outputData() As Variant Dim i As Long, j As Long, lastRowSource As Long, lastRowTarget As Long Dim rowsToDelete As Range, delCount As Long Dim totalCols As Long: totalCols = 13 Dim t As Double: t = Timer Dim professions As Object, profession As Variant Dim colWidths() As Double Dim lastRowAfterInsert As Long ' تخزين أبعاد الأعمدة من ورقة معاشات Set wsTarget = ThisWorkbook.Sheets("معاشات") ReDim colWidths(1 To totalCols) For i = 1 To totalCols colWidths(i) = wsTarget.Columns(i).ColumnWidth Next i Set wsSource = ThisWorkbook.Sheets("DATA") With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .StatusBar = "جاري معالجة البيانات..." End With ' تثبيت الخط في الخلية E3 With wsTarget.Range("E3") .Font.Name = "Arial" .Font.Bold = True End With lastRowSource = wsSource.Cells(wsSource.Rows.Count, "M").End(xlUp).Row If lastRowSource < 5 Then GoTo CleanUp sourceData = wsSource.Range("A5:M" & lastRowSource).Value ' إنشاء قاموس للمهن Set professions = CreateObject("Scripting.Dictionary") For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then profession = Trim(sourceData(i, 5)) If Not professions.Exists(profession) Then professions.Add profession, Nothing End If End If Next i ' معالجة كل مهنة For Each profession In professions.Keys ' إنشاء أو تحديد الورقة الخاصة بالمهنة On Error Resume Next Set wsNew = ThisWorkbook.Sheets(profession) On Error GoTo 0 If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = profession Else ' حذف البيانات القديمة مع الحفاظ على التنسيق wsNew.Cells.ClearContents End If ' نسخ الترويسة من ورقة معاشات wsTarget.Range("B3:J3").Copy wsNew.Range("B3").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False ' نسخ البيانات الخاصة بالمهنة الحالية delCount = 0 ReDim outputData(1 To UBound(sourceData, 1), 1 To totalCols) For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" And Trim(sourceData(i, 5)) = profession Then delCount = delCount + 1 For j = 1 To totalCols If (j = 9 Or j = 12) And IsDate(sourceData(i, j)) Then outputData(delCount, j) = Format(sourceData(i, j), "yyyy/mm/dd") Else outputData(delCount, j) = sourceData(i, j) End If Next j End If Next i If delCount > 0 Then lastRowTarget = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row If lastRowTarget < 5 Then lastRowTarget = 4 Set targetRange = wsNew.Range("A" & lastRowTarget + 1).Resize(delCount, totalCols) targetRange.Value = Application.Index(outputData, Evaluate("ROW(1:" & delCount & ")"), Evaluate("COLUMN(A:M)")) ' تطبيق التنسيق With targetRange .Borders.LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders.ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With wsNew.Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With ' ضبط ارتفاع الصفوف wsNew.Rows("5:" & (lastRowTarget + delCount)).RowHeight = 20.25 ' ضبط عرض الأعمدة For i = 1 To totalCols wsNew.Columns(i).ColumnWidth = colWidths(i) Next i ' تطبيق التنسيق الشرطي With wsNew.Range("A5:M" & (lastRowTarget + delCount)) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If Set wsNew = Nothing Next profession ' حذف الصفوف من ورقة DATA Set rowsToDelete = Nothing For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then If rowsToDelete Is Nothing Then Set rowsToDelete = wsSource.Rows(i + 4) Else Set rowsToDelete = Union(rowsToDelete, wsSource.Rows(i + 4)) End If End If Next i If Not rowsToDelete Is Nothing Then rowsToDelete.Delete Shift:=xlUp End If ' تحديث ورقة معاشات With wsTarget lastRowAfterInsert = .Cells(.Rows.Count, "B").End(xlUp).Row If lastRowAfterInsert >= 5 Then With .Range("A4:M" & lastRowAfterInsert) .Sort Key1:=.Columns(12), Order1:=xlAscending, _ Header:=xlYes, Orientation:=xlTopToBottom End With With .Range("A5:M" & lastRowAfterInsert) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With .Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With .Rows("5:" & lastRowAfterInsert).RowHeight = 20.25 With .Range("A5:M" & lastRowAfterInsert) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If End With ' تحديث الصيغ With wsTarget .Columns("D").NumberFormat = "0" .Range("A5").FormulaR1C1 = "=IF(RC[1]<>"""",SUBTOTAL(3,R5C2:RC[1]),"""")" .Range("A6:A10000").FormulaR1C1 = .Range("A5").FormulaR1C1 End With عد_الذكور_والإناث_والمعاشات CleanUp: With Application .Calculation = xlCalculationAutomatic .EnableEvents = True .ScreenUpdating = True .StatusBar = False End With Debug.Print "تم الانتهاء في: " & Round(Timer - t, 2) & " ثانية" End Sub

العفو اخي الكريم ..

وعليكم السلام ورحمة الله وبركاته ،، أخي الكريم قبل البدء بطرح الحلول ، هل يوجد اي شروط للسجل الذي تريد حذف أول 3 أرقام منه كما ذكرت ، أم سيكون على جميع السجلات في الحقل EmpID داخل الجدول T1 ؟؟ اذا كان بدون شروط ، فهنا أنت تحتاج لاستعلام تحديث بسيط كالتالي :- UPDATE T1 SET EmpID = Left(EmpID, Len(EmpID) - 3) WHERE Len(EmpID) > 3; في مثالك بعد التعديل ، شوف السجلات قبل تشغيل الاستعلام Query1 وبعد تشغيله إن كانت النتيجة سليمة .. DDFinding Differences-Last.mdb

نرجو من مشرفينا الكرام إغلاق هذا الموضوع ، فقد تم الحل في موضوع آخر ، وتم الإعلان والتوجيه له في المشاركة السابقة.

العفو اخي الكريم 😇 أين كانت مشكلتك ؟؟

تفرق ايه ؟؟؟ الإستدعاء واحد من هنا أو من هناك .. على العموم انا خارج المنزل وبعيد عن الكمبيوتر ، بأقرب فرصة نتابع 😇

اخي الكريم ما تم فقط هو اضافة الدالة السابقة ، وإنشاء مربع نص في التقرير فقط لا غير . ولم يتم تعديل أو فتح أي جزء آخر للأسف 🙄 .

لا اعلم طبيعة العمل في مشروعك الذي تقوم بالتطبيق عليه ، ولكن كما رأيت في ملفك المرفق تم التطبيق بنفس الخطوات التي ذكرتها لك سابقاً.. او ارسل نسختك ليتم التنفيذ عليها.

ولا يهمك اخي سامر .. 😇

طيب أخي @2saad ، حتى لا نحمّل الاستعلام مصدر سجلات التقرير حملاً زائداً ( من وجهة نظري ) ، قمت بإنشاء دالة بسيطة تقوم بجلب التلاميذ الذين الدمج لهم <> 1 ، كالتالي :- Public Function GetDamgStudents(lagnaID As Long) As String Dim sql As String Dim hasRecords As Boolean sql = "SELECT Studentname FROM Tbl_student WHERE id_lagna = " & lagnaID & " AND damg_id <> 1 AND alsaf_Id = " & Forms!frm_Reports!ComboSaf With CurrentDb.OpenRecordset(sql) hasRecords = (Not .EOF) Do Until .EOF GetDamgStudents = GetDamgStudents & !Studentname & vbCrLf .MoveNext Loop .Close End With If Not hasRecords Then GetDamgStudents = "لا يوجد تلاميذ دمج لهذه اللجنة" Else GetDamgStudents = Trim(GetDamgStudents) End If End Function وعليه قمت بإنشاء مربع نص = "lstDamgStudents" مصدر بياناته استدعاء الدالة بهذا الشكل :- =GetDamgStudents([id_lagna]) وهذه صورة للنتيجة ، علماً أنك لم تقم بارفاق الملف الصحيح كما في الصورة ( ولا أعتقد أنه ضروري ، بما انك تنقل التعديلات الي مشروعك الرئيسي ) وعليه ، يصبح تعديلي في هذا الملف :- Data21.zip * ملاحظة ، تم عمل تنسيقات بسيطة لاخفاء مربع النص عندما لا يكون في اللجنة تلاميذ دمج ، وتستطيع الاستغناء عن هذه الفكرة طبعاً .

ان كان التعبير والشرح غير كافي ، فارسل صورة توضح المطلوب يا صديقي ( على اعتبار انه نفس الطلب الرئيسي لك )

انصحك بالبدء بفهم طبيعة تركيب وانشاء استعلام ، ثم توسع للذهاب الى الفلترة من خلال الـ VBA 😉 قمت بانشاء الاستعلام في وضع التصميم أولاً وتعريف المعاملات من خلال الزر ، ثم تضمن الشروط . حيث قمت بإضافة الشروط كما في الصورة التالية مراعياً اظهار السجلات كاملة عند فتح النموذج :- أما فيما يخص جزء PARAMETERS ( أو ما يعرف بالمعاملات ) وشرحها ، فهي كالآتي بشرح مختصر بسيط :- يتم توجيه الحديث مباشرة أنه يا آكسيس هناك بعض القيم سيتم إدخالها من النموذج ( Frm_Bons ) ، فقم بحفظها مؤقتاً لاستخدامها في الفلترة التي سيتم تطبيقها . وتم تطبيق جزء الشروط ( WHERE ) ، كما رأيت سابقاً مع استخدام الدالة Like لعدم التقيد بقيمة محددة كاملة ، بل يمكنك كتابة جزء من القيمة النصية المطلوب البحث عنها والفلترة ، بمعنى أصح وإن جاز التعبير هو نظام يشبه محركات البحث المعتادة مثل جوجل . يعني باختصار ، الاستعلام يعمل عمل فلتر الماء على مراحل يمرر البيانات عبر مرشح العميل أولاً ، ثم مرشح نوع البون ، ثم مرشح التاريخ ، ثم مرشح المنتج . وبالتالي أفضل الاستعلام أكثر من الفلترة من خلال الأكواد لسهولة ومرونة التعامل معه بشكل بصري أكثر من الكتابي . هذا والله أعلم طبعاً 😇

استبدل الإستعلام السابق ، بالاستعلام التالي :- PARAMETERS [Forms]![Frm_Bons]![cmpagen] Long, [Forms]![Frm_Bons]![cmpkind] Text ( 255 ), [Forms]![Frm_Bons]![fromdate] DateTime, [Forms]![Frm_Bons]![todate] DateTime, [Forms]![Frm_Bons]![cmb_prod] Text ( 255 ); SELECT tbl_Bons.Bon_nu, tbl_Bons.BonDate, tbl_Bons.Bon_kind, tbl_Bons.agent_id, tbl_Bons.carNo, tbl_Bons.driver_nm, tbl_Bons.Prod_no, tbl_Bons.Qty, tbl_Bons.sale_price, tbl_Bons.Remark, [sale_price] * [Qty] AS txtall FROM tbl_Bons WHERE (tbl_Bons.agent_id=Forms!frm_Bons!cmpagen Or Forms!Frm_Bons!cmpagen Is Null) And (tbl_Bons.Bon_kind Like "*" & Forms!Frm_Bons!cmpkind & "*" Or Forms!Frm_Bons!cmpkind Is Null) And ((tbl_Bons.BonDate>=Forms!Frm_Bons!fromdate Or Forms!Frm_Bons!fromdate Is Null) And (tbl_Bons.BonDate<=Forms!Frm_Bons!todate Or Forms!Frm_Bons!todate Is Null)) And (tbl_Bons.Prod_no Like "*" & Forms!Frm_Bons!cmb_prod & "*" Or Forms!Frm_Bons!cmb_prod Is Null); تطبيق الفلترة على 4 مراحل كما تريد ، ومن رأيي الإستعلام أفضل لك للتعامل مع الفلترة المتعددة

تريد الأسهل أم الأصعب لك ولعملك ؟؟ ممكن توضح أكثر ؟

العفو أخي الكريم .. لا تنسى إغلاق مواضيعك 😇 .

صورة توضيحية ..

كلامك سليم 100% ، ولكن هناك حل لهذه المشكلة أيضاً نستخدم هذا الكود في حدث "في الحالي - On Current" مع الكود السابق Private Sub Form_Current() Dim bVisible As Boolean bVisible = (Me.total_out <> 0) With Me.CmdM .Transparent = Not bVisible .Enabled = bVisible End With With Me.CmdL .Transparent = Not bVisible .Enabled = bVisible End With With Me.CmdB .Transparent = Not bVisible .Enabled = bVisible End With End Sub DD-JO_2010.accdb

وعليكم السلام ورحمة الله وبركاته .. فليسمح لي أخي @kkhalifa1960 ، لم لا نستخدم الدالة "Transparent" !!!! في حدث عند الرسم ( On Paint ) للجزء ( التفاصيل - Detail ) للنموذج ، نكتب الكود التالي :- If Me.total_out = 0 Then Me.CmdM.Transparent = True Me.CmdL.Transparent = True Me.CmdB.Transparent = True Else Me.CmdM.Transparent = False Me.CmdL.Transparent = False Me.CmdB.Transparent = False End If والنتيجة في الصورة التالية :- مرفق مثال الأستاذ خليفة مشكوراً على طرحه ، مع أن الأحق بإرفاق ملف هو أخونا @jo_2010 ، حتى لا نقع في اختلاف الأفكار والتسميات .... إلخ DD-JO_2010.accdb