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

k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & lr & ", $D$3)", "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) أخي الفاضل @Foksh . أولا كان سبب مداخلتي هو أنني أحببت فقط أن أشارككم أساتذتي الكرام من باب التشريف لا التكليف ورغبة مني في الإسهام قدر المستطاع في إثراء هذا الموضوع أما بخصوص كود الأستاذ بشير @عبدالله بشير عبدالله فأراه يؤدي المطلوب بكفاءة واقتدار وجهده محل تقدير الفكرة التي تطرأ في هذا السياق تتعلق بالتعامل مع نطاقات ديناميكية في الأوراق الجديدة التي يتم إنشاؤها استنادا إلى القيم الموجودة في العمود M العمود F والخلية B3-D3-وG3 إذا ماذا يحدث عند نسخ الأعمدة؟ الفكرة الجوهرية: عند إنشاء ورقة جديدة بناء على تصنيف معين (مثل عمود "النوع" أو غيره) يتم نسخ الصف الثالث الذي يحتوي على معادلات مثل COUNTIF لكن بما أن كل ورقة جديدة قد تحتوي على عدد صفوف مختلف فإن نطاق البيانات الذي تطبق عليه المعادلات قد يختلف استخدام معادلة مثل =COUNTIF($F$5:$F$10000, $D$3) فهذا نطاق ثابت (من F5 إلى F10000) ولكن في الواقع بعض الأوراق الجديدة قد لا تحتوي على هذا العدد من الصفوف وبالتالي استخدام نطاق ثابت في جميع الأوراق قد يؤدي إلى نتائج غير دقيقة أو إلى تحميل غير ضروري على المعادلات لذا جاءت فكرة جعل المعادلات ديناميكية ومرتبطة بعدد الصفوف الفعلي الموجود في كل ورقة جديدة والهدف من هذا التحديث هو تحسين الأداء وضمان دقة النتائج خاصة عند التعامل مع عدد كبير من الأوراق التي تحتوي على بيانات متفاوتة هذا التحديث يعتبر اجتهادا شخصيا لتحسين العمل وليس أمرا ضروريا لكنه يساهم بشكل كبير في جعل المعادلات أكثر مرونة وتكيفا مع محتوى كل ورقة تم استخدام الدالة SUBTOTAL داخل الكود لترقيم البيانات تلقائيا في الأوراق الجديدة نظرا لقدرتها على تجاهل الصفوف المخفية سواء تم إخفاؤها يدويا أو باستخدام الفلتر عكس الترقيم العادي تستخدم SUBTOTAL في الكود لعرض ترقيم ديناميكي يتغير تلقائيا عند تصفية البيانات مما يجعل الجداول أكثر وضوحا وسهولة في القراءة عند العمل على بيانات مفلترة أما عن سبب إضافتي لها في الكود فهو أنني لاحظت أن صاحب الموضوع الأخ المحترم @algammal يستخدم بالفعل هذه الدالة في ورقة المعاشات وبالتحديد في العمود A حيث يكتب الصيغة التالية: =IF(B5<>"",SUBTOTAL(3,$B$5:B5),"") وهذا يعكس رغبته في ترقيم الصفوف الظاهرة فقط وبالتالي كان من المنطقي الاستمرار على نفس النمط داخل الكود البرمجي لضمان تناسق النتائج ودقتها بعد تصفية البيانات كما تمت الإشارة سابقا فإن استخدام دالتي COUNTIF و SUBTOTAL في الكود ليس أمرا إلزاميا أو ضروريا بحد ذاته لكنه جاء في إطار تحسين سير العمل ورفع جودة النتائج 1) الهدف من ذلك: تقديم مخرجات أكثر دقة واحترافية 2)تحسين تجربة المستخدم عند تصفية البيانات (الفلاتر) 3) التأكد من أن المعادلات تعمل بشكل ديناميكي وسلس حتى مع تغير محتوى الأوراق 👈 ورغم أن الزميل @algammal لم يشر صراحة إلى هذه النقط إلا أننا دائما نحاول من خلال مداخلاتنا الاشتغال على مثل هذه الجوانب التقنية الدقيقة لمساعدة الإخوة الأعضاء في بناء حلول مرنة وقابلة للتوسع تتماشى مع مختلف سيناريوهات العمل ضمن ملفاتهم نعم في هذا الكود تم استخدام المصفوفات الفرعية من خلال السطر: ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) المصفوفة a() تستخدم لتخزين البيانات بشكل مؤقت في الذاكرة قبل نسخها إلى ورقة العمل الجديدة هذا يساعد في تحسين الأداء بشكل كبير لأننا نعمل مع المصفوفة في الذاكرة بدلا من تعديل الخلايا مباشرة في كل مرة التحديد الديناميكي لحجم المصفوفة باستخدام ReDim يتم تحديد حجم المصفوفة بناء على البيانات الموجودة في النطاق OnRng الذي يحتوي على البيانات الفعلية وهذا يتيح للكود أن يتعامل مع نطاقات بيانات ذات حجم غير ثابت وأهميتها تخزين الصفوف التي تتطابق مع الشرط المحدد (مثل تطابق القيم في العمود الخامس مع f) مما يتيح لنا معالجتها دفعة واحدة بعد ذلك في الورقة الجديدة أخي الفاضل @Foksh أشكرك مرة أخرى على مداخلتك القيمة والتي أضافت للموضوع بعدا تقنيا هاما كما أشرت فإن استخدام الدوال والمصفوفات بهذه الطريقة لا يأتي من باب الضرورة بل هو اجتهاد لتحسين الأداء وجودة النتائج خاصة في بيئات العمل التي تعتمد على بيانات كبيرة ومتغيرة باستمرار إن مشاركتك محل تقدير واحترام ونحن نثمن حرصك على إثراء الحوار الفني بملاحظاتك الدقيقة ومداخلاتك الهادفة وأتمنى أن تكون هذه التوضيحات قد ساهمت في الفهم الكامل لاستخدام المصفوفات ودالة SUBTOTAL والمعادلات الديناميكية داخل الكود إذا كان لديك أي استفسارات إضافية أو ملاحظات أخرى فلا تتردد في طرحها فالحوار التقني بيننا يثري الجميع فمهما بلغ فهمنا أو اجتهادنا نبقى دائما في مقام التلاميذ ضمن هذا الصرح العظيم نستزيد من علم أساتذتنا وننهل من خبراتهم فالعلم بحر لا ساحل له دمتم بخير وأتمنى لك التوفيق دائما

شكرا استاذنا الفاضل محمد هشام. على اطرائك كود متقن فائف السرعة سلمت يمينك وزادك من فضله وعلمه

وعليكم السلام ورحمة الله تعالى وبركاته أستاذنا الفاضل @Foksh أشكرك جزيل الشكر على كلماتك الطيبة وتقديرك الذي يعكس أخلاقك العالية تواجدك بيننا هو شرف كبير لنا وأنت بالفعل مصدر إلهام لنا جميعا في عالم الإكسس كذلك أود أن أشكر الأخ العزيز @algammal على إبداعه في تقديم طلبه بكل أدب وتقدير مشيرا إلى الجهد الكبير الذي بذله الأستاذ عبدالله في تلبية طلبه هذه اللفتة تعكس الروح الطيبة بين أعضاء المنتدى وتشجع على تبادل الخبرات بكل تقدير واحترام وهو أمر نفتقده أحيانا في بعض الحالات كما لا يفوتني أن أوجه التحية والتقدير للأستاذ الفاضل @عبدالله بشير عبدالله على مشاركته القيمة وجهوده المستمرة في دعم ومساعدة أعضاء المنتدى اسمحوا لي أن أساهم بدوري في إثراء هذا الموضوع من خلال هذا الكود المتواضع رغم أن الحلول المطروحة هنا رائعة بالفعل إلا أنني حاولت التركيز على تحسين الأداء الزمني للكود ليكون أسرع في بعض الحالات خاصة في التعامل مع البيانات الكبيرة إضافة إلى ذلك قمت بتعديل بعض النقاط لتحسين تجربة المستخدم مثل تسريع عمليات النسخ والتنسيق وتقليل التكرار في العمليات مما يساعد في تقليل الوقت المستغرق لتنفيذ الكود آمل أن تساهم هذه الإضافة في تحسين تجربتنا المشتركة في استخدام إكسل بشكل أكثر كفاءة بالطبع يسرني أن أسمع آراءكم وتعليقاتكم حول أي تحسينات إضافية يمكن أن تفيد الجميع مع خالص التحية والتقدير Sub TransferData() Const début As Long = 5: Const Height As Double = 20.25 Const départ As String = "A": Const Fin As String = "M" Const harder As String = "A3:M4" Dim CrWS As Worksheet, tmp As Worksheet, dest As Object, OnRng As Variant Dim i As Long, lastRow As Long, tbl As String, f As Variant, k As Variant Dim Irow As Long, a() As Variant, n As Long, lr As Long On Error GoTo OnError Set CrWS = Sheets("معاشات"): Set dest = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, départ).End(xlUp).Row If lastRow < début Then Exit Sub SetApp False OnRng = CrWS.Range(départ & début & ":" & Fin & lastRow).Value For i = 1 To UBound(OnRng, 1) tbl = Replace(Trim(OnRng(i, 5)), "/", "_"): tbl = Replace(tbl, "\", "_") If Len(tbl) > 0 Then dest(tbl) = Empty Next i Application.DisplayAlerts = False For Each tmp In ThisWorkbook.Worksheets If Not tmp Is CrWS Then: If dest.exists(tmp.Name) Then tmp.Delete Next tmp Application.DisplayAlerts = True For Each f In dest.keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True CrWS.Range(harder).Copy tmp.[A3].PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) n = 0 For Irow = 1 To UBound(OnRng, 1) If Trim(OnRng(Irow, 5)) = f Then n = n + 1 For i = 1 To UBound(OnRng, 2) a(n, i) = OnRng(Irow, i) Next i End If Next Irow If n > 0 Then tmp.[A5].Resize(n, UBound(OnRng, 2)).Value = a CrWS.Range("A5:M" & n + 4).Copy tmp.[A5].PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False End If CrWS.Columns("A:M").Copy tmp.Columns("A:M").PasteSpecial Paste:=xlPasteColumnWidths Application.CutCopyMode = False lr = tmp.Cells(tmp.Rows.Count, départ).End(xlUp).Row For i = 1 To lr tmp.Rows(i).RowHeight = Height Next i k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & _ lr & ", $D$3)", "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) tmp.Range("A5:A" & lr).Formula = "=IF(B5<>"""",SUBTOTAL(3,$B$5:B5),"""")" tmp.[A4].Select Next f On Error Resume Next CrWS.Range("A5:M" & lastRow).FormatConditions.Copy tmp.Range("A5:M" & n + 4) On Error GoTo OnError CrWS.Activate CleanUp: SetApp True MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub OnError: Resume CleanUp End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable .EnableEvents = enable .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل البيانات من شيت إلى عدة شيتات مستقلة v3.xlsb

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

السلام عليكم ورحمة الله وبركاته أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه. أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا. كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal. تحياتي واحترامي لك أخي العزيز، وبعد إذن معلمنا، هذه محاولة متواضعة لتنفيذ طلب أخينا العزيز، حسب ما فهمته من سؤاله. أتمنى أن تقوم بتجربة الحل، وإذا كان هناك أي تعديل أو توضيح إضافي، فأنا على أتم الاستعداد . مع خالص التحية والتقدير لكما ولكل منابعى المنتدى، الكود Sub ترحيل_البيانات() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim startTime As Double: startTime = Timer Dim sheetName As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..." End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub dataArray = wsMain.Range("A5:M" & lastRow).Value For i = 1 To UBound(dataArray, 1) sheetName = Trim(dataArray(i, 5)) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True Dim key As Variant, rowIndex As Long For Each key In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = key wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False wsMain.Rows("3:4").Copy wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For rowIndex = 1 To UBound(dataArray, 1) If Trim(dataArray(rowIndex, 5)) = key Then wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow) targetRow = targetRow + 1 End If Next rowIndex For i = 1 To wsMain.UsedRange.Rows.Count If i <= wsNew.UsedRange.Rows.Count Then wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight End If Next i For i = 1 To 13 wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i Next key wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume CleanUp End Sub الملف ترحيل البيانات من شيت إلى عدة شيتات مستقلة.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 = رمز العمل (اختياري ، حيث يعتمد على الجهاز) هذا من وجهة نظري بعد التعديل فيما يتوافق مع اكسل ( مشتق من أكواد آكسيس ) ولكم التجربة طبعاً لأنني حالياً لا أملك جهاز البصمة المذكور نوعه سابقاً ..

أخي الكريم الأستاذ @عبدالله بشير عبدالله أحسنت وأحسن الله إليك. أخي الكريم الأستاذ @محمد هشام. أحسنت وأحسن الله إليك؛ وشفا الله ابنك وعافاه ورزقك بره وقرت به عيناك آمين رب العالمين. أخي الكريم الأستاذ @Foksh أحسنت وأحسن الله إليك. السلام عليكم جميعا ورحمة الله وبركاته الله الله؛ لله دركم جميعا؛ لقد أسرتوني بتواضعكم ونبل أخلاقكم وفيض علمك ورقي حواركم؛ والله إنها لمتعة علمية لا تدانيها متعة؛ أن تجد نفسك بين قامات علمية يتحلى كل منهم بنبل الأخلاق وأخلاق العلماء؛ يتبارى كل منهم في مباراة علمية من أجل أن يصيب الهدف بأفضل ما لديه من معلومات لا يضن أو يبخل بها على السائل؛ فلقد أصبتم جميعا وأثريتم الموضوع إثراء يفوق الحد والتوقعات وما أجمل وأروع تحليلكم؛ فخيركم من تعلم العلم وعلمه؛ ... وتعليمه لمن لا يعلمه صدقة؛ وأدعو الله أن يظلنا جميعا في ظله يوم لا ظل إلا ظله. ولكم مني جميعا خالص الود والاحترام والتقدير؛ على ما قدمتموه لنا في هذا الموضوع؛ جعلكم الله عونا لكل من أراد العون ومثلا يحتذى لكل من أراد القدوة. والله أدعو أن نلتقي يوما ما؛ وإن لم يكن لقاءنا في الدنيا؛ أن يجمعنا الله بكم في الآخرة؛ وجزاكم الله عنا جميعا خير الجزاء. أحبكم جميعا في الله؛ وأفتخر أنني عضو في هذا المنتدى الطيب؛ زادكم الله علما ونفع بكم آمين رب العالمين.

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

بارك الله بكم جميعاً أخي الأستاذ @محمد هشام. ، وأثابكم الله على ما قدمتم .. واسمح لي بسؤال متفرع فيما يخص الكود الذي طرحته .. هل لك أن تشرح لي حاجتنا لـ (COUNTIF و SUBTOTAL) ؟🤗؟ ( من باب كسب المعلومة ) وهل اعتمدت فعلاً على مصفوفات فرعية ؟؟ (ReDim a() ومن باب المشاركة وبما أنني قد أخطأت في ماركتي الأولى سابقاً 😅 ، سأقدم فكرتي والتي لا اعتقد انها بكفاءة أفكاركم أهل الديار 🤗 . Sub CopyDataToWorksheets() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant, formatsArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim sheetName As String, startTime As Double: startTime = Timer Const ROW_HEIGHT As Double = 20.25 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات" End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then GoTo CleanUp dataArray = wsMain.Range("A5:M" & lastRow).Value formatsArray = wsMain.Range("A1:M" & lastRow).FormatConditions For i = 1 To UBound(dataArray, 1) sheetName = CleanSheetName(Trim(dataArray(i, 5))) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True For Each sheetName In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = sheetName wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For i = 1 To UBound(dataArray, 1) If CleanSheetName(Trim(dataArray(i, 5))) = sheetName Then wsNew.Range("A" & targetRow & ":M" & targetRow).Value = Application.Index(dataArray, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)) targetRow = targetRow + 1 End If Next i If Not IsEmpty(formatsArray) Then On Error Resume Next wsMain.Range("A5:M" & lastRow).FormatConditions.Copy wsNew.Range("A5:M" & targetRow - 1) On Error GoTo 0 End If With wsNew .Rows.RowHeight = ROW_HEIGHT For i = 1 To 13 .Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i .Range("E3").Font.Name = "Arial" End With Next sheetName wsMain.Range("E3").Font.Name = "Arial" wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With Debug.Print "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية" Exit Sub ErrorHandler: MsgBox "حدث خطأ في السطر " & Erl & ": " & Err.Description, vbCritical + vbMsgBoxRight,"" Resume CleanUp End Sub Function CleanSheetName(sName As String) As String Dim illegalChars As Variant, char As Variant illegalChars = Array("\", "/", ":", "?", "*", "[", "]") CleanSheetName = sName For Each char In illegalChars CleanSheetName = Replace(CleanSheetName, char, "_") Next char If Len(CleanSheetName) > 31 Then CleanSheetName = Left(CleanSheetName, 31) End If End Function

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

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

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

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

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

اعرض الملف 🎁📅 :: المخطط السنوي للإجازات :: 🌼🌷 :: عرض جميع إجازات الموظفين على الجدول الزمني Gantt Cart دايناميكي 😊👌🏻 السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم هذه الهدية المتواضعة :: المخطط السنوي للإجازات :: وهو عبارة عن تقويم سنوي لإجازات الموظفين يتم رسمه دايناميكيا على مخطط رسم بياني يسمى Gantt Chart 👌 يمتاز التصميم بالسهولة والجمال والإبداعية وقد شرحت كيفية استخدامه في الفيديو التالي ✌ في التحديث الجديد 1.7 تم إضافة حقل لمجموع عدد الأيام سنويا ... مع دعم للإجازات عابرات القارات (الإجازات التي تمتد لعدة سنوات كالإجازات الدراسية الطويلة) ظهور عدد الأيام في جميع النوافذ من مميزات هذا المخطط: - عرض جميع الإجازات في صفحة واحدة يسهل من قرائتها ومراجعتها. - تصميم رائع وألوان جميلة . - سهل الاستخدام . - وكذلك هذا المخطط يمكن استخدامه للمشاريع بدل الإجازات أو عرض مدة الإيجارات أو .. أو .. أو ... حيث لا حدود للإبداع 🙂 :: وأخيرا وليس آخرا :: :: لا تنسونا ووالدينا من صالح دعواتكم الطيبة 🙂 🌹🌷 :: صاحب الملف Moosak تمت الاضافه 01 ينا, 2025 الاقسام قسم الأكسيس

الله يحيك تفضل ملفين الأول بالمعادلات و الثاني بالكود مجموع المدة كاوقات.xlsx مجموع المدة كاوقات.xlsm

و عليكم السلام ورحمة الله وبركاته تفضل المطلوب بالملف الدالة =WRAPROWS(L1:L72;8) Wrap Test2.xlsx

سعيد جدا لسعادتك بها 😄✌ .. وهناك تحديث مهم لها أيضا قادم في الطريق .. إن شاء الله 😊🌷 التحديث القادم تم إضافة كتابة أكواد ال DB.OpenRecordset للجداول .. قادمة في الطريق العقل المفكر والمبدع المتميز يتكلم .. وناسي أنه هو اللي مكسر الدنيا 😎 هذا واحد من أحلامي ✌ ياليت أحصل فرصة وأعمل درس في جماليات تصاميم النماذج يا ترى هل فيه حد مهتم بهذا الموضوع ؟؟

وعليكم السلام ورحمة الله وبركاته .. من خلال المعطيات التي ذكرتها .. الوزن الصافي (طن) : مثلاً 197 طن درجات القمح : درجة 23.5 بسعر 2200 جنيه درجة 23.0 بسعر 2150 جنيه درجة 22.5 بسعر 2100 جنيه الخصومات : دمغة : 1 جنيه النقابة : 0.55 جنيه لكل أردب ستكون المعادلة في اكسل افتراضاً بالشكل التالي :- = (الوزن_الصافي * 1000 / 150) * (IF(الدرجة>=23.5, 2200, IF(الدرجة>=23, 2150, IF(الدرجة>=22.5, 2100, 0))) - (دمغة + (الوزن_الصافي * 1000 / 150 * 0.55))) وكفكرة على كيفية تطبيقها : قم بإعداد جدول بهذه الأعمدة ( أسماء الأعمدة في الصف الأول ) :- A : رقم الكرتونة B : الوزن الصافي (طن) C : درجة القمح D : السعر E : الخصومات F : الصافي في الخلية D2 (السعر) = المعادلة التالية :- =IF(C2>=23.5, 2200, IF(C2>=23, 2150, IF(C2>=22.5, 2100, 0))) في الخلية E2 (الخصومات) = المعادلة التالية أيضاً :- =1 + (B2*1000/150*0.55) -في الخلية F2 (الصافي) = المعادلة : =(B2*1000/150*D2)-E2 طبعاً على افتراض أن الأردب = 150 كيلو جرام حسب النظام المصري .