كل الانشطه

وعليكم السلام ورحمة الله وبركاته ،، باعتقادي ما ينطبق على اكسيس يمكن ان ينطبق على اكسل . فأولاً يلزمك تثبيت مكتبة 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

تم اضافة الاسطر المضللة في الكود بما يتناسب مع الحالة قيد المشكلة

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

السلام عليكم عتدي جدول T1 واريد انشاء استعلام يحذف لي 03 ارقام على يمين عدد عمود EmpID DDFinding Differences-Last.mdb مثال رقم 101010101010 يصبح 101010101

اشكرك اخي طاهر .... بارك الله فيك .... شغال على برنامج قطعني عن المنتدى ... جرب المرفق على الحالات السابقة والحالة الحالية حتى نتأكد من الكود .... Taher_1.mdb

شكرا استاذ على الاهتمام وحمد لله على سلامتك وينك ياراجل غاب اثرك استاذي العزيز الحالة هذه وقعت السنة الفارطة دفع الا مبلغ 1500 وهذه السنة دفع المبلغ كاملا والمقدر ب 3000 دج الكود لما بحث وجد انه دفع 1500 العام الماضي وكان الدفع خلال مارس 2024 واستفادتة كانت الى غاية 2024/06/30 اي بعد 01 جويلية الى غاية 2024/12/30 لم يكمل 1500 ويكون محروم من الاستفادة فياريت زيادة صيغة لهذه الحالة في الكود اما التاريخ لازم يكون الى غاية 2026/02/28 لانه دفع المبلغ كاملا لسنة 2025

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

اي التواريخ صحيحة .....

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

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

شكرا جزيلا اتحلت المشكلة وربنا يبارك في صحتك

وعليكم السلام انصحك بقراءة هذه المواضيع: . . . . اما بالنسبة الى برنامجك ، فتفضل التصفية بالاستعلام (اما التصفية في النموذج ، فرجاء قراءة اول موضوع اعطيتك رابطه اعلاه). 1630.10.accdb

شكرا أنا آسف بتعب حضرتك معاي

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

طيب هل ينفع أجلب الدالة من الاستعلام

استاذنك ان الخلية لو ناتجة من معادلة (بها )معادلة يكون فيه تغيير الى اللغة العربية والعكس بحيث يتم التغيير سواء خلية او مربع نص كذلك الاحتفاظ بجميع المعادلات والتنسيقات الاخرى كرقم او صيغة تاريخ

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

هل الجزئية ديالموجودة بجدول التلاميذ ( التصفية ) ( ترتيب حسب ) متعلقة بالدالة

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

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