كل الانشطه

تفضل هذه احدى الحلول لاحظ ان الاستعلام الجدولي يجب ان يشتمل على 3 حقول فأكثر لذا اضفت حقل للجدول كمعرف للجنة احصاء2.rar

الف شكر لتعبكم ... ولكنى لم اوضح المقصود جيدا أريد ان يكون التقرير يشبه هذا اى تكون الاحصاءات متجاوة بجوار اسم اللجنة افقيا واللجنة اسمها يذكر مرة واحدة ولا يكرر احصاء2.accdb

أخي الكريم / Foksh السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا على المعلومة الجديدة بالنسبة لي أما بخصوص الكود التالي - والذي لكم الفضل في أن يظهر بهذا الشكل - والذي أعنيه فهو موجود في ورقة2 شيت ( معاشات) وبدايته هي: Sub CopyDataToWorksheets() Dim wsData As Worksheet Dim wsNew As Worksheet Dim cell As Range Dim lastRow As Long Dim i As Long Dim sheetNames As Object Set sheetNames = CreateObject("Scripting.Dictionary") ' تعيين الورقة التي تحتوي على البيانات (اسم الورقة هو "معاشات") Set wsData = ThisWorkbook.Sheets("معاشات") Application.ScreenUpdating = False ' تعطيل تحديث الشاشة لتسريع الأداء ' حساب آخر صف غير فارغ في العمود E lastRow = wsData.Cells(wsData.Rows.Count, "E").End(xlUp).Row ' تحويل البيانات في العمود E إلى أسماء الأوراق العمل ونسخ الصفوف المناسبة For Each cell In wsData.Range("E5:E" & lastRow) ' التحقق من صحة الأحرف في اسم الورقة العمل Dim sheetName As Variant sheetName = Trim(CStr(cell.Value)) ' التحقق من صحة اسم الورقة العمل المحدثة If sheetName <> "" Then ' إضافة اسم الورقة الجديدة إلى القاموس (دون تكرار) If Not sheetNames.exists(sheetName) Then sheetNames(sheetName) = 1 End If End If Next cell ' حذف الأوراق القديمة المطابقة وإنشاء أوراق جديدة For Each wsNew In ThisWorkbook.Sheets If Not wsNew Is wsData Then If sheetNames.exists(wsNew.Name) Then ' حذف الأوراق القديمة Application.DisplayAlerts = False wsNew.Delete Application.DisplayAlerts = True End If End If Next wsNew ' إنشاء الأوراق الجديدة ونسخ البيانات المطابقة For Each sheetName In sheetNames.keys If Not SheetExists(CStr(sheetName)) Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = CStr(sheetName) wsData.Rows(4).Copy Destination:=wsNew.Rows(4) i = 5 ' تبدأ من الصف الثاني Do Until IsEmpty(wsData.Cells(i, "E")) If wsData.Cells(i, "E").Value = CStr(sheetName) Then wsData.Rows(i).Copy Destination:=wsNew.Rows(wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row + 1) End If i = i + 1 Loop ' تعديل عرض الأعمدة في الورقة الجديدة وفقًا للعرض في الورقة الأصلية wsData.Columns.AutoFit wsNew.Columns.AutoFit End If Next sheetName Application.ScreenUpdating = True ' تمكين تحديث الشاشة مرة أخرى End Sub Function SheetExists(sheetName As String) As Boolean Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name = sheetName Then SheetExists = True Exit Function End If Next ws SheetExists = False End Function فقط أود أن ألفت الانتباه إلى أن الكود الموجود في (Module1) يعمل بكفاءة عالية ولا أريد التعديل عليه حيث أنه مرتبط بزر (ترحيل المحالين على المعاش) في شيت (DATA) إلى شيت (معاشات)؛ وما أريده أخي الكريم هو الكود المذكور عاليه والمرتبط بزر (ترحيل البيانات) الموجود في شيت (معاشات) مع الشيتات الناتجة عنه وهي: (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل)؛ ما أريده ألخصه فيما يلي: 1= أريد ظهور الخلايا (J3:B3) بنفس تنسيقها في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) وأن تظل ثابته لا تتأثر بترحيل البيانات في المرات القادمة حي أنها تختفي كلما قمت بترحيل البيانات. 2= أريد ارتفاع الصف (20.25) في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) بأكملها من أول صف لآخر صف. 3= أريد عرض الأعمدة من (B:A) فقط في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) مطابقة لعرض الأعمدة المذكورة في شيت (معاشات)؛ حيث أن عرض الأعمدة من (M:C) مضبوطة ولا تحتاج تعديل. ملحوظة: أما بخصوص الخط في الخلية (E3) شيت (معاشات) فقد تم حله بفضل الله. هذا والله الموفق والمستعان وجزاكم الله خير الجزاء؛ وأسعدكم في الدارين: الدنيا والاخرة وتقبلوا خالص احترامي وتقديري

استاذى الفاضل إليك قاعدة مصغرة للتعديل عليها JO_Lab.rar

حياكم الله محتاج كود يعمل على : 1. نوع الخروج (خروجية) 2. يرحل كل من لديه مدة الخروج اكثر من سبع ساعات - فاذا كانت 8 ساعة مدة الخروج ترحل سبع ساعات وتبقى ساعة واحدة مدور على الشهر الذي يلية وهكذا فاذا كن لديه 15 ساعة ترحل 14 ساعة وتبقى ساعة واحد اذ ان كل سبع ساعات تعتبر اجازة يوم واحد 3. كل البيانات المشمولة بالشروط اعلاه ترحل الى شيت اسمه مقبرة الخروجيات وتحذف من السجل 4 . والمتبقي يكتب مدور من الشهر السابق في عمود جديد أو اي فكرة ترونه مناسبة مشكورين - وأي شيء غير مفهوم ارجو اعلامي ترحيل الى شيت اخر لمن لديه سبع أو اكثر.xlsx

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

DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET Tbl_Lab_Requests.R_External_lab = ""المختبر"" " & _ " WHERE (((Tbl_Lab_Requests.PCode)= [Forms]![Laboratory]![id]));" DoCmd.RunSQL "UPDATE Tbl_Lab_Requests SET Tbl_Lab_Requests.R_External_lab = ""المختبر"" " & _ " WHERE (((Tbl_Lab_Requests.PCode)= [Forms]![Laboratory]![id]));"

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

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

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

الخبراء الافاضل بعد التحية والاحترام عندى نموذج فرعى مستمر داخل نموذج رئيسى عند الوقوف علي اى سجل من السجلات يوجد مربع نص فى النموذج الرئيسي ياخد قيمتة من كود السجل الموجودفى النموذج الفرعى وعندى زر تحديث لإضافة كلمة المختبر لحقل R_external_lab فى الجدول بشرط يكون كود الجدول مساوى لرقم dا الموجود فى الرئيسي لكن التحديث يحدث فقط فى السجل الحالى الموجود فى النموذج الرئيسى وليس ارجو يكون طلبى واضح إليكم صورة من الكود

نعم الاستعلام هو مصدر الفورم الفرعي والتقرير أيضا

اجعل الاستعلام الحاصل مصدرا لتقريرك احصاء.rar

وإياكم

ارجو المساعدة فى اريد عمل تقرير يظهر امام كل لجنة احصاء بعدد المعاونون الملاحظون رئيس اللجنة المراقب الأول .. ولكم الشكر احصاء.accdb

جزاك الله كل خير

و عليكم السلام ورحمة الله و بركاته تفضل نقل البيانات من عمود لاخر(2).xlsx

السلام عليكم محتاج انقل البيانات من عمود 1 الي عمود 2 بدون الخلايا التي تحتوي علي صفر او فارغه مع النقل بالترتيب ويعمل بشكل اتوماتيكي اذا تغيرت البيانات في العمود 1 جزاكم الله عنا كل خير نقل البيانات من عمود لاخر.xlsx

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

تمام - ساحاول اتباع الخطواتواعلامك بالنتائج = ولكن اصبر عليه - لاني في البيت والجهاز بالدائرة ولدينا عطلة

الكود الذي عملنا عليه سابقا يقوم بتحويل الأرقام إلى عربية أو إنجليزية لكن يتم ذلك عن طريق تغيير محتوى الخلية مباشرة وهذا يؤدي إلى فقدان أي صيغة كانت موجودة في الخلية للأسف الإكسيل لا يدعم تغيير عرض الأرقام من إنجليزية إلى عربية أو العكس داخل نفس الخلية بدون التأثير على محتواها بمعنى: لا يمكنك تحويل الأرقام داخل الخلية إلى العربية دون تعديل المحتوى نفسه مجرد اقتراح قد يكون مناسبا لتنفيذ طلبك مع الحفاظ على الصيغ: يمكن إظهار الأرقام العربية بصريا فقط وذلك عبر إضافة شكل شفاف (Textbox) فوق الخلية بهذا الأسلوب تبقى الصيغ تعمل كما هي والخلية الأصلية لا تتغير لاكن يمكنك محاكاة المظهر العربي للأرقام بصريا فقط دون التأثير على الصيغ أو البيانات كما في المثال التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v4.xlsb

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

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

مشكور