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

**بسم الله الرحمن الرحيم** الأساتذة الكرام أعضاء هذا المنتدى الموقر، يطيب لنا أن نعبر عن أصدق مشاعر الامتنان والتقدير لجهودكم القيّمة التي تبذلونها في إثراء هذا المنتدى بعلمكم وخبرتكم. فما تقدمونه من إجابات وافية، ومناقشات هادفة، وتوجيهات حكيمة، ليس إلا دليلًا على سموّ أخلاقكم وحرصكم على نشر الفائدة والعلم. لا يسعنا إلا أن نشكر لكم تفانيكم في توضيح الغامض، وتبسيط المعقد، وإضاءة دروب المعرفة للجميع. جهودكم لم تكن مجرد مشاركات عابرة، بل كانت بصمات تُسهم في بناء مجتمع متعلم ومتكاتف. أسأل الله أن يجزيكم خير الجزاء على ما تقدّمونه، وأن يبارك في وقتكم وعلمكم، ويجعل أعمالكم في ميزان حسناتكم. دمتم ذخرًا لهذا الصرح، ونبراسًا يهدي الباحثين عن المعرفة. واخص بالذكر استاذي أبو جودي استاذي Foksh استاذي kkhalifa1960 استاذي ناقل تقبلوا فائق الاحترام،

وعليكم السلام ورحمة الله وبركاته ،، باعتقادي ما ينطبق على اكسيس يمكن ان ينطبق على اكسل . فأولاً يلزمك تثبيت مكتبة 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 أحسنت وأحسن الله إليك. السلام عليكم جميعا ورحمة الله وبركاته الله الله؛ لله دركم جميعا؛ لقد أسرتوني بتواضعكم ونبل أخلاقكم وفيض علمك ورقي حواركم؛ والله إنها لمتعة علمية لا تدانيها متعة؛ أن تجد نفسك بين قامات علمية يتحلى كل منهم بنبل الأخلاق وأخلاق العلماء؛ يتبارى كل منهم في مباراة علمية من أجل أن يصيب الهدف بأفضل ما لديه من معلومات لا يضن أو يبخل بها على السائل؛ فلقد أصبتم جميعا وأثريتم الموضوع إثراء يفوق الحد والتوقعات وما أجمل وأروع تحليلكم؛ فخيركم من تعلم العلم وعلمه؛ ... وتعليمه لمن لا يعلمه صدقة؛ وأدعو الله أن يظلنا جميعا في ظله يوم لا ظل إلا ظله. ولكم مني جميعا خالص الود والاحترام والتقدير؛ على ما قدمتموه لنا في هذا الموضوع؛ جعلكم الله عونا لكل من أراد العون ومثلا يحتذى لكل من أراد القدوة. والله أدعو أن نلتقي يوما ما؛ وإن لم يكن لقاءنا في الدنيا؛ أن يجمعنا الله بكم في الآخرة؛ وجزاكم الله عنا جميعا خير الجزاء. أحبكم جميعا في الله؛ وأفتخر أنني عضو في هذا المنتدى الطيب؛ زادكم الله علما ونفع بكم آمين رب العالمين.

و عليكم السلام ورحمة الله و بركاته استخدام Power Query الخطوات: فتح ملف إكسيل جديد: افتح ملف إكسيل جديدًا أو موجودًا حيث تريد دمج البيانات. الوصول إلى Power Query: انتقل إلى علامة التبويب البيانات (Data). انقر على الحصول على البيانات (Get Data) من مجلد (From Folder). تحديد المجلد: اختر المجلد الذي يحتوي على ملفات الإكسيل التي تريد دمجها. ستظهر نافذة تعرض جميع الملفات في المجلد. انقر على تحميل (Load) أو تحويل البيانات (Transform Data) لفتح محرر Power Query. دمج البيانات: في محرر Power Query، سترى قائمة بجميع الملفات. انقر على أيقونة دمج (Combine) بجوار العمود "Content". اختر الجدول أو الورقة (Sheet) التي تريد دمجها من كل ملف (إذا كانت تحتوي على أوراق متعددة). يمكنك تنظيف البيانات (مثل حذف الأعمدة غير الضرورية) قبل الدمج. تحميل البيانات: انقر على إغلاق وتحميل (Close & Load) لإرسال البيانات المددمجة إلى ملف الإكسيل الجديد. تحديث البيانات: إذا أضفت ملفات جديدة إلى المجلد لاحقًا، انقر بزر الفأرة الأيمن على الجدول في إكسيل واختر تحديث (Refresh) لتحديث البيانات. ملاحظة: تأكد أن جميع الملفات لها نفس الهيكلية (نفس أسماء الأعمدة وترتيبها) لتجنب الأخطاء.

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 على مشاركته القيمة وبعد إذنه طبعا بالفعل الدالة: =TEXT(L2, "mmm dd, yyyy") مفيدة جدا لإظهار التاريخ بتنسيق واضح لكنها ترجع نصا وليس تاريخا فعليا مما قد يعيق عمليات مثل الترتيب أو الفلترة أو الحسابات المرتبطة بالتواريخ كبديل يعيد قيمة التاريخ الأصلية بدون الوقت وبشكل يمكن Excel التعامل معه كتاريخ حقيقي يمكن استخدام: =INT(L2) أو =QUOTIENT(L2, 1) كلاهما يفصل التاريخ عن الوقت تماما (وتظل قابلة للحسابات مثل التصفية والفرز) ملاحظة: تأكد من تنسيق الخلايا الناتجة كـ [تاريخ] لضمان عرضها بالشكل الصحيح وإذا كنت مهتما أيضا بفصل الوقت بشكل مستقل فيمكن استخدام: =L2 - INT(L2) وهي مفيدة إذا احتجت لاحقا إلى عرض الوقت وحده أو تحليله تحياتي وتقديري للجميع 2 تمديد.xlsx

في التحديث الجديد ، تم إضافة ميزات جديدة . بحيث :- تم دعم الحقول المدمجة في جوجل شيت . تم إضافة ميزة التحكم بتحديد صف العناوين ( للأوراق التي تدعم ترويسة ) في جوجل شيت . إصلاح بعض الأفكار السابقة للتعامل بشكل أسهل وأسرع عند الإستيراد من جوجل شيت . * ملاحظة :- لا ننصح باستخدام تسميات عربية للأوراق في جوجل شيت ( بسبب تغير سياسة جوجل شيت المتنقلة بين فترة وأخرى في إعدادات الـ API ) Excel Importor V3.0.accdb

تفضل أخي الفاضل ملفين أحدهما معادلات و الآخر أكواد. اختر ما يحلو لك. ناجح-راسب.xlsm ناجح-راسب.xlsx

نقل الصور من حقل Attachment في Access إلى مجلد باستخدام VBA نعم، يمكنك نقل الصور من حقل Attachment في Access إلى مجلد مجاور للبرنامج باستخدام كود VBA. إليك كيفية القيام بذلك: كود VBA لنسخ الملفات المرفقة إلى مجلد كيفية استخدام الكود استبدل "اسم_جدولك" باسم الجدول الذي يحتوي على حقل المرفقات استبدل "اسم_حقل_المرفقات" باسم حقل Attachment في جدولك سيتم إنشاء مجلد يسمى "Attachments" بجوار ملف قاعدة البيانات إذا لم يكن موجوداً سيتم حفظ جميع الملفات المرفقة في هذا المجلد ملاحظات مهمة الكود يتعامل مع جميع أنواع الملفات المرفقة، ليس فقط الصور يتم إنشاء أسماء ملفات فريدة لتجنب الكتابة فوق الملفات الموجودة يتم تخطي الملفات المخفية مثل Thumbs.db تأكد من أن لديك أذونات الكتابة في المجلد الهدف يمكنك تعديل الكود حسب احتياجاتك الخاصة، مثل تصفية أنواع ملفات معينة (مثل .jpg, .png فقط) أو تنظيم الملفات في مجلدات فرعية. واليك الكود :- Sub ExportAttachmentsToFolder() Dim db As DAO.Database Dim rs As DAO.Recordset Dim rsAttach As DAO.Recordset2 Dim fldAttach As DAO.Field2 Dim strFilePath As String Dim strFileName As String Dim strFullPath As String Dim strFolderPath As String Dim i As Integer ' تحديد مسار المجلد الهدف (بجوار قاعدة البيانات) strFolderPath = CurrentProject.Path & "\Attachments\" ' إنشاء المجلد إذا لم يكن موجوداً If Dir(strFolderPath, vbDirectory) = "" Then MkDir strFolderPath End If ' فتح جدول أو استعلام يحتوي على حقل المرفقات Set db = CurrentDb() Set rs = db.OpenRecordset("اسم_جدولك") ' استبدل باسم الجدول الفعلي ' تحديد حقل المرفقات Set fldAttach = rs.Fields("اسم_حقل_المرفقات") ' استبدل باسم حقل المرفقات ' التكرار خلال السجلات Do Until rs.EOF ' فتح سجل المرفقات للسجل الحالي Set rsAttach = fldAttach.Value ' التكرار خلال المرفقات في السجل الحالي i = 0 Do Until rsAttach.EOF ' تجنب الملفات المخفية (مثل thumbs.db) If Not (rsAttach.Fields("FileName") Like "~*" Or _ rsAttach.Fields("FileName") = "Thumbs.db") Then ' إنشاء اسم فريد للملف لمنع التكرار strFileName = rsAttach.Fields("FileName") strFullPath = strFolderPath & strFileName ' التأكد من عدم وجود ملف بنفس الاسم While Dir(strFullPath) <> "" i = i + 1 strFullPath = strFolderPath & i & "_" & strFileName Wend ' حفظ المرفق إلى الملف rsAttach.Fields("FileData").SaveToFile strFullPath End If rsAttach.MoveNext Loop rsAttach.Close rs.MoveNext Loop ' تنظيف الذاكرة rs.Close Set rsAttach = Nothing Set fldAttach = Nothing Set rs = Nothing Set db = Nothing MsgBox "تم تصدير المرفقات بنجاح إلى: " & strFolderPath, vbInformation End Sub

وعليكم السلام رجاء اعمل نسخة احتياط من برنامجك ، واحفظها في مكان آمن بعيد عن ملفات عملك. هذا الموضوع يفيدك في تصدير المرفقات من الجدول الى مجلد في الكمبيوتر . وهذا الموضوع لحذف المرفقات من الجداول (ولكن يجب ان تتأكد ان جميع المرفقات تم تصديرها اولا)

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

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

وعليكم السلام ورحمة الله تعالى وبركاته أستاذنا الفاضل @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

و عليكم السلام ورحمة الله و بركاته تفضل نقل البيانات من عمود لاخر(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

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

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

اما اذا اردت النموذج الصغير دائما في المقدمة ، افتحه بهذه الطريقة DoCmd.OpenForm "FINISHED CAED",,,,,acDialog بدلا عن DoCmd.OpenForm "FINISHED CAED",acNormal

وعليكم السلام ورحمة الله وبركاته .. فليسمح لي أخي @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

وعليكم السلام ورحمة الله وبركاته تفضل شيت 2.xlsm

وعليكم السلام ورحمة الله وبركاته ،، أخي الكريم ، قم بتعديل استعلام النموذج الى الاستعلام التالي :- PARAMETERS [Forms]![Frm_Bons]![cmpagen] Long, [Forms]![Frm_Bons]![cmpkind] Text ( 255 ), [Forms]![Frm_Bons]![fromdate] DateTime, [Forms]![Frm_Bons]![todate] DateTime; 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)); وفي مربعات النص الخاصة بالتواريخ ( من - إلى ) و مربعي التحرير والسرد ( cmpagen و cmpkind ) اجعل لهم الحدث بعد التحديث = Me.Requery أما بخصوص الزر CmdRemoveFilter لأزالة الفلترة ، فقد تم تعديله كالتالي :- Private Sub CmdRemoveFilter_Click() Me.FilterOn = False Me.cmpagen = Null Me.cmpkind = Null Me.fromdate = Null Me.todate = Null Me.Requery End Sub ملفك بعد التعديل :- 10.accdb

وعليكم السلام ورحمة الله وبركاته ،، جرب هذا التعديل على حسب ما فهمت من الشرح Sub Test_Optimized() Dim ws As Worksheet, dataArr As Variant, outputArr() As Variant Dim i As Long, ii As Long, p As Long, startRow As Long, endRow As Long Dim chunkSize As Long, chunkStart As Long, chunkEnd As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set ws = ActiveSheet chunkSize = 5000 ReDim outputArr(1 To chunkSize * 10, 1 To 14) With ws .Columns("Q:P").Clear .Columns("P").ColumnWidth = 12 .Range("R1").Resize(, 14).Value = Array("الدفعة", "ج", "ت ح", "ت م", "ت ع", "ل ع", "ل ح", "ل م", "ل ع1", "ر ع1", "ل ح1", "ر ح1", "ل م", "ر م1") .Range("R1").Resize(, 14).Interior.Color = RGB(146, 205, 220) .Range("R1").Resize(, 14).HorizontalAlignment = xlCenter For chunkStart = 2 To 13000 Step chunkSize chunkEnd = chunkStart + chunkSize - 1 If chunkEnd > 13000 Then chunkEnd = 13000 dataArr = .Range("A" & chunkStart & ":N" & chunkEnd).Value p = 1 For i = LBound(dataArr, 1) To UBound(dataArr, 1) If IsNumeric(dataArr(i, 2)) And IsNumeric(dataArr(i, 3)) Then startRow = dataArr(i, 2) endRow = dataArr(i, 3) For ii = startRow To endRow outputArr(p, 1) = dataArr(i, 1) outputArr(p, 2) = ii outputArr(p, 3) = dataArr(i, 4) outputArr(p, 4) = dataArr(i, 5) outputArr(p, 5) = dataArr(i, 6) outputArr(p, 6) = dataArr(i, 7) outputArr(p, 7) = dataArr(i, 8) outputArr(p, 8) = dataArr(i, 9) outputArr(p, 9) = dataArr(i, 10) outputArr(p, 10) = dataArr(i, 11) outputArr(p, 11) = dataArr(i, 12) outputArr(p, 12) = dataArr(i, 13) outputArr(p, 13) = dataArr(i, 14) outputArr(p, 14) = dataArr(i, 14) p = p + 1 Next ii End If Next i If p > 1 Then .Range("R" & chunkStart).Resize(p - 1, 14).Value = outputArr ReDim outputArr(1 To chunkSize * 10, 1 To 14) End If Next chunkStart End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

شكرا جزيلا اخي الكريم kkhalifa1960 على المرور وبارك الله بكم لك كل الاحترام والتقدير

و عليكم السلام ورحمة الله و بركاته نعم، يمكنك طباعة الـ UserForm في Excel باستخدام VBA، ولكن يجب أولاً تحويل اليوزر فورم إلى صورة (Bitmap) ثم إرسالها إلى ورقة عمل أو كائن للطباعة. للأسف، الـ VBA لا يدعم طباعة اليوزر فورم مباشرة مثل ورقة العمل. يفضل ارفاق ملف لتوضيح المطلوب. وبعد البحث في منتديات أوفيسنا وجدت الحل و قمت بالتعديل في الكود رابط الملف الأصلي https://www.officena.net/ib/topic/103266-معاينة-الطباعة-على-اليوزر-فورم/#google_vignette و إليك الملف بعد التعديل preview on userform.xlsm

الاخوة الافاضل Foksh kkhalifa1960 كل شكري وامتناني على اهتمامكم وردكم الغالي والاستاذ والمعلم القدير أستاذ jjafferr بارك الله فيك وجعله دائما في ميزان حسناتك وزادك من العلم فأنت مثل ما قيل خير الناس أنفعهم للناس خالص شكري وتقديري لكم جميعا

بارك الله بكم جميعاً أخي الأستاذ @محمد هشام. ، وأثابكم الله على ما قدمتم .. واسمح لي بسؤال متفرع فيما يخص الكود الذي طرحته .. هل لك أن تشرح لي حاجتنا لـ (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

ممكن ترسل مرفق علشان نساعدك .

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

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

استبدل الإستعلام السابق ، بالاستعلام التالي :- 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 مراحل كما تريد ، ومن رأيي الإستعلام أفضل لك للتعامل مع الفلترة المتعددة

الحمد لله على انقضاء الحاجة فائدة : يمكن توظيف المتغير هذا .. بحيث يمكن تضمينه قيمة نصية صريحة

اخي احمد اولا : لم توفق باختيار عنوان مناسب للموضوع يوافق ما عرضته ثانيا : ومن شرحك .. طريقتك في تصميم مشروعك غير صحيحة الصحيح ان تكون جميع اسماء المعلمين ( ابتدائي / متوسط / ثانوي ) ضمن جدول واحد فقط ، وتعمل حقل يبين مرحلته كذا ومن خلال التصفية في الاستعلام يمكنك حصر معلمي كل مرحلة وعرضهم لوحدهم والتعامل معهم

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

كما تريد أخي @سامر محمود ،، تفضل هذا التعديل :- Pepsi-fockh.zip

السلام عليكم ورحمة الله وبركاته هذا تحديث بسيط ومهم في نفس الوقت على هذه الأداة الجميلة 🙂 ( عون المثابر في الحصول على أسماء العناصر (الإصدار 3.0)) كما علمتم هذه الأداة صممتها بفضل الله في أكسس تقوم بإحضار وسرد أسماء العناصر لك لكي تستطيع نسخها ولصقها في أي مكان تريد بكل سهولة ويسر 🙂 شخصيا أستفدت كثيرا منها وسهلت علي الكثير من الجهد وقلصت من وقت العمل بحمد الله وفضله. :: ما الجديد في النسخة 3.0 :: تم إضافة خانة في الأخير خاصة بالجداول فقط .. : وهي عند اختيار الجدول يتم كتابة جمل SQL أستعلامات أساسية للجدول المختار مع ذكر أسماء حقول الجدول مع مراعاة أنواع الحقول وكتابتها بشكل سليم في الكود .. طبعا الأداة ستعطيك الجمل الاستعلامية الأربعة SELECT, INSERT INTO, UPDATE ,DELETE والكود الناتج جاهز للصقه مباشرة في محرر الأكواد VBA .. عليك فقط أن تقوم ببعض التعديلات الطفيفة كإزالة الحقول الزائدة أو الغير مستهدفة وكذلك تحديد الشرط Where في حال التحديث أو الحذف مثلا . :: لقطة للنسخة 3.0 :: وهذا مثال على جمل ال SQL الناتجة : ' SELECT statement Dim sqlSelect As String sqlSelect = "SELECT [ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB]" sqlSelect = sqlSelect & vbCrLf & " FROM [SampleTable]" '============================================================ ' INSERT INTO statement Dim sqlInsert As String sqlInsert = "INSERT INTO [SampleTable] ([ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB])" sqlInsert = sqlInsert & vbCrLf & " VALUES (" & var_ID & ", '" & var_FirstName & "', '" & var_LastName & "', '" & var_Gender & "', " & var_Age & ", '" & var_Email & "', '" & var_Phone & "', '" & var_Education & "', '" & var_Occupation & "', " & var_Salary & ", " & var_StaffNumber & ", " & IIf(var_IsActive, -1, 0) & ", #" & var_DOB & "#)" '============================================================ ' UPDATE statement Dim sqlUpdate As String sqlUpdate = "UPDATE [SampleTable]" sqlUpdate = sqlUpdate & vbCrLf & " SET [ID] = " & var_ID & ", [First Name] = '" & var_FirstName & "', [Last Name] = '" & var_LastName & "', [Gender] = '" & var_Gender & "', [Age] = " & var_Age & ", [Email] = '" & var_Email & "', [Phone] = '" & var_Phone & "', [Education] = '" & var_Education & "', [Occupation] = '" & var_Occupation & "', [Salary] = " & var_Salary & ", [StaffNumber] = " & var_StaffNumber & ", [IsActive] = " & IIf(var_IsActive, -1, 0) & ", [DOB] = #" & var_DOB & "#" sqlUpdate = sqlUpdate & vbCrLf & " WHERE [SomeField] = SomeValue" '============================================================ ' DELETE statement Dim sqlDelete As String sqlDelete = "DELETE FROM [SampleTable]" sqlDelete = sqlDelete & vbCrLf & " WHERE [SomeField] = SomeValue" الشرح القديم للأداة على اليوتيوب 🙂 متابعة ممتعة 😊👌🏼 ولا أستغني عن آراءكم وملاحظاتكم .. 🙂 لتحميل الملف :

الغالي الاستاذ @Foksh دايما بشوف افكارك جديدة والله انت وباقي الزملاء الخبراء وبتعلم منها بشكرك علي كرم الرد والاستجابة وبحاول اعدل بعد اذنك حاجات بسيطة لتلبية احتياجات العمل الاستاذ الصديق المحترم الاخ @kkhalifa1960 بشكرك علي كرم الرد والمساعدة الغالية الثمينة والله ودايما بتكون اول انسان يمد ايد المساعدة

بارك الله في الاستاذين حجازي ومحمد هشام وجعله في ميزان اعمالكما وشفى نجل الاستاذ محمد هشام

على افترض أن لدينا 100 معلم منهم 8 بلجنة التصحيح ولدينا 12 لجنة امتحان ولدينا 8 مواد بــ 8 ايام امتحانات اليكم التوزيع مع مراعاة العدالة في كل شئ ... واصدار تقريران الاول التوزيع حسب كل مادة امتحان كل مادة بصفحة .... والثاني للاحصائيات فقط اذهب لنهايته ستحصل على جدول بالاحصائيات .. ولكم مني كل الاحترام والتقدير . توزيع المراقبين على اللجان.rar

أخي قم بالدخول إلى محرر الاكواد وشغل الكود او أعد ربط الزر بالكود copy ملاحظة في حالة كانت لك رغبة بالاحتفاظ بالبيانات السابقة بمعنى انك تريد ترحيل بيانات جديدة كل مرة في اخر صف فارغ دون حدف البيانات القديمة قم بتعطيل هدا الصف من الكود Range("A2:A200,C2:C200,E2:E200,G2:G200,I2:I200,k2:k200,M2:M200,O2:O200,Q2:Q200,S2:S200").ClearContents واليك كود اخر للترحيل بنفس الطريقة مع نسخ البيانات في اخر صف فارغ من العمود الاول Oracle_Sub Sub CopyDataBlocks() Dim SourceSheet As Worksheet Dim TargetSheet As Worksheet Dim ColHeaders As Range Dim MyDataHeaders As Range Dim DataBlock As Range Dim c As Range Dim Rng As Range Dim i As Integer Set SourceSheet = Sheets("Sheet1") Set TargetSheet = Sheets("Sheet2") With TargetSheet Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) End With With SourceSheet Set MyDataHeaders = .Range("A1:U1") Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp)) Set Rng = Rng.Resize(DataBlock.Rows.Count, 1) For Each c In MyDataHeaders If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) <> 0 Then i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0) Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value End If Next c End With End Sub اليك الملف مرة اخرى عليه جميع الاكواد ولك الاختيار Exmple2.xlsm

حسب فهمي للمطلوب أنك تريد تجميع نفس الخلية من جميع الشيتات لذا يمكن استعمال نفس تصميم الشيتات في شيت row مرفق ملفك وبه المعادلة الطبيعية في الجزء العلوي وكذلك دالة معرفة vba اسمها sumall في الجزء السفلي ودالة أخرى لصناعة المعادلة العادية بالكود بالتوفيق جمع الخلية من جميع الشيتات.xlsb

استعمل هذه المعادلة بدل التي وضعتها لتفادي الخطأ في حال تم كتابة نص او اي شيء غير الارقام في العامودين I و J الملف مرفق من جديد marwa_New_2.xlsm

في نهاية الكود اضف هذا السطر كما في الصورة بهذه الطريقة يقوم البرنامج بازالة التكرارات في الصفوف اوتوماتيكياً (دوت ان تشغر بذلك)

السلام عليكم أخي أبو البراء الغالي: قمت بحذف الكود في الملف ونسخت بدلاً عنه الكود كاملاً مع اقترحت تعديله فلم أفلح إلا بعد نظرت إلى أمر لم يكن بالحسبان لدي .Sheets("Sheet1").Delete حيث أن أسماء الأوراق لدي بالعربية أصبحت كما يلي: ("ورقة 1") بدلاً من ("sheet1").. وقد نجحت المحاولة نجاحاً باهراً.... تهانينا لكم على هذا العمل الررائع والسلام عليكم.

السلام عليكم و رحمة الله أخي إضافة لحلول الأخوة الجميلة يمكنك إستخدام معادلة الصفيف التالية =SUM(IF(B3:E3<$B$2:$E$2,1)) و في حال رغبتك في إلغاء السطر الثاني من الجدول يمكنك إستخدام نفس المعادلة السابقة مع تعديل بسيط =SUM(IF(B3:E3<{50,50,25,25},1))

فكرة رائعة للتعارف وأتمني ان يجمعنا الجمع في مناسبة مثلا ومعرفة بعضنا البعض ------------------------- الاسم : طارق أنور علي عفيفي سنة الميلاد : 1978 م المهنة : محاسب بهيئة الطاقة الجديدة والمتجددة تتبع وزارة الكهرباء وبع الظهر ( صيانة كمبيوتر وتجميعه - وعمل شبكات صغيرة - والأهم هو صناعة البرمجيات والتطبيقات بإستخدام أكسس ) التعليم : بكارولويس تجارة شعبة محاسبة جامعة الأزهر حاصل علي شهادة من معهد التخطيط القومي بــ (. Net Work and NT4 Ad ) الحالة الاجتماعية :أعزب بلد الجنسية / بلد الاقامة : مصر / مصر أقسام الاهتمام فى المنتدي :كل الإهتمام بالأكسيس حاليا . وفي مخططي كل مواضيع المنتدي قريبا معلومات أخري : أعشق الأكسس جدا جدا جدا و أنشأت تطبيقات مختلفة له وتطبيقات متميزة ، و استخدام ال vba به . وقمت بعمل بعض البرامج وبيعها " وإن شاء الله سوف أقدم كل ما أستطيع من إفادة للموقع بعرض بعض الأفكار تليفون موبايل : 0105162066 email : tar_afifi60@yahoo.com

الاسم : رضا عزت إبراهيم عقيل السن : 21.5 سنة التعليم : بكالوريوس تجارة الحالة الاجتماعية ،، متزوج البلد : مصر محافظة دمياط ،،، اعمل في مصر مدرس كمبيوتر في مركز تابع للتربية والتعليم وملكاً لعائلتي أقيم في المملكة العربية السعودية ،،، وأعمل بها مصمم في مطبعة (( أجيد ،، برامج التصميم ،، الأوفيس وخاصة الوورد )) والعديد من البرامج الخدمية الأخرى ....