كل الانشطه

وعليكم السلام ورحمة الله وبركاته ،، باعتقادي ما ينطبق على اكسيس يمكن ان ينطبق على اكسل . فأولاً يلزمك تثبيت مكتبة SDK منموقع الشركة ZKTeco من هذه الصفحة هنا . حيث انها تحتوي المكتبة على وظائف تسمح بالاتصال المباشر بالجهاز . باستخدام اكود التالي :- ' أولاً: تحتاج إلى إضافة المرجع إلى مكتبة ZKBioAPI ' من أدوات > مراجع > بحث عن ZKBioAPI أو ZKFPEngX Sub ConnectToZKDevice() Dim zk As New ZKBioAPI Dim connHandle As Long Dim ret As Long Dim ipAddress As String Dim port As Integer Dim deviceTime As String Dim userCount As Integer ipAddress = "192.168.1.201" ' استبدل بIP الجهاز port = 4370 ret = zk.Connect_Net(ipAddress, port, connHandle) If ret = 0 Then MsgBox "تم الاتصال بنجاح", vbInformation ret = zk.GetDeviceData(connHandle, "USER_INFO_COUNT", userCount) MsgBox "عدد المستخدمين: " & userCount, vbInformation GetAttendanceLogs zk.Disconnect (connHandle) Else MsgBox "فشل الاتصال بالجهاز. الخطأ: " & ret, vbCritical End If End Sub وهذه دالة لجلب سجلات الحضور :- Sub GetAttendanceLogs() Dim zk As New ZKBioAPI Dim connHandle As Long Dim ret As Long Dim ipAddress As String Dim port As Integer Dim attendanceLogs() As AttendanceLog Dim logCount As Long Dim i As Integer ipAddress = "192.168.1.201" port = 4370 ret = zk.Connect_Net(ipAddress, port, connHandle) If ret = 0 Then ret = zk.GetAttendanceLogs(connHandle, attendanceLogs, logCount) If ret = 0 And logCount > 0 Then Sheets("السجلات").Cells.Clear Sheets("السجلات").Range("A1:D1").Value = Array("المستخدم", "التاريخ", "الوقت", "الحالة") For i = 0 To logCount - 1 With attendanceLogs(i) Sheets("السجلات").Cells(i + 2, 1).Value = .UserID Sheets("السجلات").Cells(i + 2, 2).Value = Format(.Date, "yyyy/mm/dd") Sheets("السجلات").Cells(i + 2, 3).Value = Format(.Time, "hh:mm:ss") Sheets("السجلات").Cells(i + 2, 4).Value = .Status End With Next i MsgBox "تم جلب " & logCount & " سجلات بنجاح", vbInformation Else MsgBox "لا توجد سجلات حضور", vbExclamation End If zk.Disconnect (connHandle) Else MsgBox "فشل الاتصال بالجهاز", vbCritical End If End Sub هذا من وجهة نظري بعد التعديل فيما يتوافق مع اكسل ( مشتق من أكواد آكسيس ) ولكم التجربة طبعاً لأنني حالياً لا أملك جهاز البصمة المذكور نوعه سابقاً ..

وعليكم السلام ورحمة الله وبركاته ،، جرب أخي هذا التعديل !! 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

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

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

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

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

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

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

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

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