كل الانشطه

السلام عليكم ورحمة الله وبركاته 🙂🖐 يقول المثل : أن تأتي متأخرا خير من أن لا تأتي 😅✌ بعد جهد جهيد إنتهيت من تصميم نظام تسجيل دخول + نظام صلاحيات متطور كلما أخطو فيه خطوة أجد أنه ناقص وتطلع أفكار جديدة .. 😅👊 لذلك قلت سأنزلها كما هي الآن .. حاولت تبسيطه للمستخدم والمستفيدين منه لاحقا قدر المستطاع .. وسأبدأ بواجهة تسجيل الدخول المتواضعة : المزايا : حفظ بيانات دخول المستخدم (اختياري) الدخول مباشرة بمجرد كتابة كلمة المرور بشكل صحيح (تسريع عملية الدخول) ملاحظة : جميع كلمات المرور في البرنامج : 123 ثانيا الواجهة الرئيسية : يتم تطبيق الصلاحيات للمستخدم بمجرد تسجيل الدخول .. ثالثا : إدارة المستخدمين هنا يتم إدارة جميع ما يتعلق بمستخدمي البرنامج ( إضافة ، تعديل ، حذف ، تعيين الصلاحيات ) رابعا : إدارة مجموعات العمل والصلاحيات لكل مجموعة هنا يتم ضبط الصفحات المسموح لكل مجموعة دخولها والصلاحيات الخاصة بكل صفحة .. ومثل ماهو واضح يمكن إضافة النماذج أو إزالتها كما يحلو لك وبعد ضبط مجموعات العمل يتم تعيين كل مستخدم للمجموعة الخاصة به ، ويمكن عمل مجموعة خاصة لشخص واحد فالخيارات غير محدودة .. 🙂 الآن يمكنك الخروج من البرنامج ثم تجربة تسجيل الدخول باسم المستخدمين المسجيلين في البرنامج للاستمتاع بتجربة الصلاحيات الممنوحة لكل مستخدم 😊 وبعد الدخول للصفحات يتم تطبيق الصلحيات الخاصة بالنموذج أيضا .. وبقية الصلاحيات ستظهر حسب الزر الذي يتم الضغط عليه مزايا إضافية موجودة في البرنامج .. ولها علاقة بالأمان أيضا .. نظام النسخ الاحتياطي وله إعدادات خاصة به (نسخ احتياطي يدوي أو تلقائي ) وهو موجود في صفحة إعدادات البرنامج : ولكل مستخدم مجموعة خيارات يمكنه التحكم بها مثل ( تغيير كلمة المرور ، التشغيل عند إقلاع الجهاز ، إنشاء اختصار في سطح المكتب ، حفظ بيانات التسجيل لتسريع الدخول للبرنامج) هذه هي أهم الميزات التي يحتويها البرنامج 🙂 ولفتح البرنامج في وضع التصميم ، حتى هذي سهلة للمبرمج 😅🖐 في صفحة تسجيل الدخول وكذلك الصفحة الرئيسية يوجد هذا الزر الخاص بالمبرمج >> بعد الضغط عليه >> أدخل كلمة المرور : 123 ويمكنك تغييرها من الكود الخاص بالزر .. بتظهر لك هذي النافذة الخاصة بالمبرمج فقط : وأهم ما فيها : (1) عرض الشريط العلوي ونافذة الأكسس >> بعد تفعيله تحفظ وتشغل الماكرو وبتنفتح عندك واجهة الأكسس >> أعد تشغيل البرنامج من جديد للحصول على جميع الميزات. (2) اسم نموذج البداية >> وهو أو نموذج بيشتغل معاك في البرنامج >> وهذا يسهل على المبرمج تطبيق النظام على أي برنامج آخر 🙂 (3) اسم البرنامج (واللي ييظهر في الشريط العلوي للأكسس) : (4) رقم الإصدار (نسخة البرنامج) وتاريخها >> ويمكن الاعتماد عليها لتحديث البرنامج لاحقا .. (5) إدارة نماذج الصلاحيات >> وهي النماذج اللي ستسمح بإعطاء صلاحيات لدخولها للبرنامج .. وكذلك تعطي كل نموذج اسم صديق للمستخدم وسيتم استخدام المسمى الحقيقي للنموذج داخليا .. وهكذا أكون شرحت لكم أهم المميزات ويتبقى نقطة مهمة وهي : يمكن للمبرمج الآن الاستفادة من هذا الملف فهو قاعدة جاهزة لإنطلاق في تصميم برنامجك الخاص .. جميع الأكواد الخاصة بالصلاحيات ستجدها في الموديول التالي : وأهم ما ستحتاج معرفته في كيفية تطبيق الصلاحيات ذكرته في الملاحظات المكتوبة أول الموديول : ' (1) : لتطبيق صلاحية فتح النماذج وصلاحيات الإضافة والتعديل والحذف تضع الأسطر التالية أول الأكواد في حدث فتح النموذج '------------------------------------------------------------------------------- 'Private Sub Form_Open(Cancel As Integer) ' ' فحص صلاحة دخول النموذج ' Cancel = Not Permission_OpenForm(Me.Name, True) ' ' تطبيق صلاحيات : الإضافة / التعديل / الحذف ' Apply_Addition_Edits_Delete_Permissions (Me.Name) 'End Sub '------------------------------------------------------------------------------- ' (2) : لتطبيق صلاحيات الطباعة والاستيراد والتصدير داخل نموذج معين تكتب هذه الأسطر لمعرفة وجود الصلاحة من عدمها ' : وكل سطر من هذه الصلاحيات يرجع لك النتيجة كما يلي ' True : مسموح ' False : ممنوع '------------------------------------------------------------------------------- ' 1- فحص صلاحية الطباعة (True/False) ' Permission_Print(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها ' 2- فحص صلاحية الاستيراد (True/False) ' Permission_Import(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها ' 3- فحص صلاحية التصدير (True/False) ' Permission_Export(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها '------------------------------------------------------------------------------- والنماذج الموجودة في البرنامج مع أزرارها تم تطبيق الأكواد عليها بشكل عملي << راجعها وأدرها لمعرفة كيفية عملها .. وهي سهلة يسيرة بفضل الله 🙂 وهذا مثال لتطبيق الصلاحية على زر الطباعة (فتح التقرير) مثلا : وهكذا بقية الصلاحيات (اطلع على بقية الموديول) تم تحويلها لأسطر قليلة بسيطة للاستفادة منها بكل يسر .. 🙂 وأخيرا تحميل البرنامج :: Moosak ‏‏Login System with permissions 1.0.accdb :: وآخر دعوانا أن الحمد لله رب العالمين ::

دا اكيد 😋😛 انا بقول زياده الخير خيرين

اوعى تكون بتعاكسني خلاص يا عم .. أول ما أخلص فحص وتجارب ، هنزلها هنا ومفتوحة المصدر كمان 😛 برضو ده آخر همي حالياً .. عايزني أروح أشتغل معاهم وأقفل على نفسي جميع مشاريعي 😂

كودعمل دوائر حول الرقم فقط وليس داخل الخلية ولاتتغير حجمها مهما تغير ارتفاع الصف او اتساع العمود ... الاقل من ٥٠ دائرة حول الرقم.xlsx

طبعا صوتك حلو 🤣🤣 لا مش كده يا عزيزي الناس بتنتظر اغلب الوقت هدايا او قوالب جاهزه ( يعني بمجرد متخلص ان شاء الله وتنزل بالمرفق ) هتلاقي التعليقات كتير تبقي غلطان يا عزيزي الموضوع ماشاء الله مجزي

ولسه فيها حاجات كتير كمان .. قلت نسمع أفكار الناس اللي بتمر من هنا ، ما سمعتش غير صدى صوتي 🤣 .. قلت وماله ؛ صوتي حلو 😎 أما موضوع مايكروسوفت ، فأنا مش موافق حتى لو عرضوا علي الشغل معاهم ,, تخيل 🤣 ...

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

دي آخر مرحلة في الوقت الحالي

وعليكم السلام ورحمة الله وبركاته .. تفضل أخي جو التعديل كالآتي :- Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As LongPtr, ByRef rgb As Long) #Else Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As Long, ByRef rgb As Long) #End If Function DialogColor(ByVal InitialColor As Long) As Long Dim lngColor As Long lngColor = InitialColor Call ChooseColor(Application.hWndAccessApp, lngColor) DialogColor = lngColor End Function ملفك المرفق .. جربه وأخبرني Database1.accdb

اخي الكريم رائع وهو المطلوب تماما ولكن عفوا ماذا يعني من الذكاء الصناعي وكيف يمكنني استخدامه

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

الخبراء الافاضل لكم خالص الشكر على مساعدتى

السلام عليكم يمكنك رفع الملف كما هو ، ويمكنك رفع الملف بضغطه ببرامج winRar او winZip ، والافضل في الضغط هو صيغة 7z. ويمكنك انزال برنامجه المجاني من هنا : https://www.7-zip.org/ ويمكنك رفع الملف على اي من مواقع رفع الملفات على الانترنت ، و ارفاق الرابط في الموضوع ، ويمكنك رفع الملف في حسابك في Google Drive ومشاركة الرابط هنا.

أعمال مميزة ، ومشاركات جميلة ومفيدة من الأساتذة @Ahmedgamall و @Barna ..

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

وهذا نفس الكلام الذي قلته شوف أخ @jo_2010 الحل مش صعب وانا ارفقت لك ملفك بعد التعديل إنما طريقة تصميم قاعدة البيانات مش صح TEST -2.rar

تفضل جرب هذا من الذكاء الاصطناع ============== Sub sale_m_Optimized() Dim wsItemOut As Worksheet, wsPerform As Worksheet, wsAccMove As Worksheet Dim wsAccMoveD As Worksheet, wsItemMove As Worksheet Dim lastRow As Long, i As Long, nRows As Long Dim dataArr As Variant Dim performArr As Variant, accMoveDArr As Variant Dim itemMoveArr As Variant, accMoveArr As Variant Dim docType As String, isReturn As Boolean Dim performStart As Long, accMoveDStart As Long Dim itemMoveStart As Long, accMoveStart As Long On Error GoTo CleanUp ' ═══════════════════════════════════════ ' إيقاف كل ما يبطئ التنفيذ ' ═══════════════════════════════════════ Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' ═══════════════════════════════════════ ' تعريف الأوراق (مرة واحدة فقط) ' ═══════════════════════════════════════ Set wsItemOut = ThisWorkbook.Sheets("itemout") Set wsPerform = ThisWorkbook.Sheets("perform") Set wsAccMove = ThisWorkbook.Sheets("accmove") Set wsAccMoveD = ThisWorkbook.Sheets("AccMove D") Set wsItemMove = ThisWorkbook.Sheets("itemmove") ' ═══════════════════════════════════════ ' فك الحماية ' ═══════════════════════════════════════ wsPerform.Unprotect Password:="m" wsAccMove.Unprotect Password:="m" wsAccMoveD.Unprotect Password:="m" wsItemMove.Unprotect Password:="m" wsItemOut.Unprotect Password:="m" ' إيقاف الفلاتر On Error Resume Next wsPerform.Rows("4:4").AutoFilter wsAccMoveD.Rows("4:4").AutoFilter wsAccMove.Rows("3:3").AutoFilter wsItemMove.Rows("4:4").AutoFilter wsItemOut.Rows("7:7").AutoFilter On Error GoTo CleanUp ' ═══════════════════════════════════════ ' التحقق من البيانات الإلزامية ' ═══════════════════════════════════════ With wsItemOut If .Cells(2, 2) = "" Or .Cells(5, 2) = "" Or .Cells(8, 2) = "" Or .Cells(2, 5) = "" Then MsgBox "أكمل البيانات: نوع الحركة, كود العميل, كود الصنف, الإذن اليدوي" .Range("B8").Select GoTo CleanUp End If End With ' ═══════════════════════════════════════ ' قراءة القيم الثابتة مرة واحدة ' ═══════════════════════════════════════ docType = wsItemOut.Cells(2, 2).Value isReturn = (docType = "مردودات مبيعات") ' ═══════════════════════════════════════ ' حساب عدد صفوف البيانات ' ═══════════════════════════════════════ lastRow = wsItemOut.Cells(wsItemOut.Rows.Count, 2).End(xlUp).Row If lastRow < 8 Then GoTo CleanUp nRows = lastRow - 7 ' قراءة كل بيانات المصدر في مصفوفة واحدة (B8:M...) dataArr = wsItemOut.Range("B8:M" & lastRow).Value ' ═══════════════════════════════════════ ' حساب صف البداية في كل شيت (مرة واحدة) ' ═══════════════════════════════════════ performStart = wsPerform.Cells(wsPerform.Rows.Count, 1).End(xlUp).Row + 1 accMoveDStart = wsAccMoveD.Cells(wsAccMoveD.Rows.Count, 1).End(xlUp).Row + 1 itemMoveStart = wsItemMove.Cells(wsItemMove.Rows.Count, 1).End(xlUp).Row + 1 accMoveStart = wsAccMove.Cells(wsAccMove.Rows.Count, 1).End(xlUp).Row + 1 ' ═══════════════════════════════════════ ' تهيئة المصفوفات للشيتات الأربعة ' ═══════════════════════════════════════ ReDim performArr(1 To nRows, 1 To 21) ' B:V ReDim accMoveDArr(1 To nRows, 1 To 21) ' B:V ReDim itemMoveArr(1 To nRows, 1 To 14) ' B:O ReDim accMoveArr(1 To nRows, 1 To 19) ' B:T ' ═══════════════════════════════════════ ' حلقة واحدة فقط لملء المصفوفات الأربع ' ═══════════════════════════════════════ For i = 1 To nRows ' ═══ شيت perform (أعمدة B:V) ═══ performArr(i, 1) = wsItemOut.Cells(3, 2).Value ' B performArr(i, 2) = wsItemOut.Cells(4, 2).Value ' C performArr(i, 3) = wsItemOut.Cells(5, 2).Value ' D performArr(i, 4) = wsItemOut.Cells(6, 2).Value ' E performArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F performArr(i, 6) = dataArr(i, 1) ' G (من B) performArr(i, 7) = dataArr(i, 2) ' H (من C) performArr(i, 😎 = dataArr(i, 3) ' I (من D) performArr(i, 9) = dataArr(i, 4) ' J (من E) ' K: الكمية (سالب إذا لم يكن مردود) If Not isReturn Then performArr(i, 10) = dataArr(i, 5) * -1 Else performArr(i, 10) = dataArr(i, 5) End If performArr(i, 11) = dataArr(i, 6) ' L (من G) performArr(i, 15) = "no" ' P performArr(i, 21) = docType ' V ' ═══ شيت AccMove D (أعمدة B:V) ═══ accMoveDArr(i, 1) = wsItemOut.Cells(3, 2).Value ' B accMoveDArr(i, 2) = wsItemOut.Cells(4, 2).Value ' C accMoveDArr(i, 3) = wsItemOut.Cells(5, 2).Value ' D accMoveDArr(i, 4) = wsItemOut.Cells(6, 2).Value ' E accMoveDArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F accMoveDArr(i, 6) = dataArr(i, 1) ' G accMoveDArr(i, 7) = dataArr(i, 2) ' H accMoveDArr(i, 😎 = dataArr(i, 3) ' I accMoveDArr(i, 9) = dataArr(i, 4) ' J accMoveDArr(i, 10) = dataArr(i, 5) ' K accMoveDArr(i, 11) = dataArr(i, 6) ' L accMoveDArr(i, 15) = "no" ' P accMoveDArr(i, 21) = docType ' V ' ═══ شيت itemmove (أعمدة B:O) ═══ itemMoveArr(i, 1) = dataArr(i, 1) ' B itemMoveArr(i, 2) = dataArr(i, 2) ' C itemMoveArr(i, 3) = dataArr(i, 3) ' D itemMoveArr(i, 4) = dataArr(i, 4) ' E itemMoveArr(i, 5) = docType ' F itemMoveArr(i, 6) = wsItemOut.Cells(3, 2).Value ' G itemMoveArr(i, 7) = wsItemOut.Cells(2, 5).Value ' H ' I/J: نفس المنطق الأصلي (أعمدة مختلفة حسب نوع الحركة) If Not isReturn Then itemMoveArr(i, 9) = dataArr(i, 10) ' J (من K في المصدر) Else itemMoveArr(i, 😎 = dataArr(i, 10) ' I (من K في المصدر) End If itemMoveArr(i, 11) = wsItemOut.Cells(5, 2).Value ' L itemMoveArr(i, 12) = dataArr(i, 12) ' M (من M في المصدر) itemMoveArr(i, 14) = wsItemOut.Cells(4, 2).Value ' O ' ═══ شيت accmove (أعمدة B:T) ═══ accMoveArr(i, 1) = wsItemOut.Cells(5, 2).Value ' B accMoveArr(i, 2) = wsItemOut.Cells(6, 2).Value ' C accMoveArr(i, 4) = wsItemOut.Cells(3, 2).Value ' E accMoveArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F accMoveArr(i, 6) = wsItemOut.Cells(4, 2).Value ' G ' H/I: نفس المنطق الأصلي If Not isReturn Then accMoveArr(i, 7) = wsItemOut.Cells(36, 8).Value ' H Else accMoveArr(i, 😎 = wsItemOut.Cells(36, 8).Value ' I End If accMoveArr(i, 10) = dataArr(i, 5) ' K accMoveArr(i, 11) = wsItemOut.Cells(34, 8).Value ' L accMoveArr(i, 13) = wsItemOut.Cells(35, 8).Value ' N accMoveArr(i, 15) = docType ' P accMoveArr(i, 18) = wsItemOut.Cells(5, 3).Value ' S Next i ' ═══════════════════════════════════════ ' كتابة المصفوفات دفعة واحدة (أسرع بـ 100 مرة) ' ═══════════════════════════════════════ wsPerform.Range("B" & performStart & ":V" & performStart + nRows - 1).Value = performArr wsAccMoveD.Range("B" & accMoveDStart & ":V" & accMoveDStart + nRows - 1).Value = accMoveDArr wsItemMove.Range("B" & itemMoveStart & ":O" & itemMoveStart + nRows - 1).Value = itemMoveArr wsAccMove.Range("B" & accMoveStart & ":T" & accMoveStart + nRows - 1).Value = accMoveArr ' ═══════════════════════════════════════ ' كتابة الصيغ دفعة واحدة لكل نطاق ' ═══════════════════════════════════════ ' --- perform --- With wsPerform .Range("A" & performStart & ":A" & performStart + nRows - 1).FormulaR1C1 = "=IF((R[-1]C)<>""م"",(R[-1]C)+1,1)" .Range("N" & performStart & ":N" & performStart + nRows - 1).FormulaR1C1 = "=(RC[-3]*RC[-2])" .Range("Z" & performStart & ":Z" & performStart + nRows - 1).FormulaR1C1 = "=IF(RC[-13]>0,RC[-13]*-1,RC[-15])" .Range("AA" & performStart & ":AA" & performStart + nRows - 1).FormulaR1C1 = "=IF(RC[-14]>0,(RC[-16]+RC[-14])/RC[-16],0)" .Range("AB" & performStart & ":AB" & performStart + nRows - 1).FormulaR1C1 = "=MONTH(RC[-25])" End With ' --- AccMove D --- With wsAccMoveD .Range("A" & accMoveDStart & ":A" & accMoveDStart + nRows - 1).FormulaR1C1 = "=ROW()-4" .Range("N" & accMoveDStart & ":N" & accMoveDStart + nRows - 1).FormulaR1C1 = "=(RC[-3]*RC[-2])" .Range("W" & accMoveDStart & ":W" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(RC[-21]<>R[-1]C[-21],SUMIFS(C[-9],C[-21],RC[-21],C[-1],RC[-1]),0)" If isReturn Then .Range("Y" & accMoveDStart & ":Y" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(OR(RC[-3]<>R[-1]C[-3],RC[-23]<>R[-1]C[-23]),SUMIFS(C[-11],C[-23],RC[-23],C[-3],RC[-3]),0)" Else .Range("X" & accMoveDStart & ":X" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(OR(RC[-2]<>R[-1]C[-2],RC[-22]<>R[-1]C[-22]),SUMIFS(C[-10],C[-22],RC[-22],C[-2],RC[-2]),0)" End If .Range("Z" & accMoveDStart & ":Z" & accMoveDStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R4C[-2]:RC[-2],R4C[-22]:RC[-22],RC[-22])-SUMIFS(R4C[-1]:RC[-1],R4C[-22]:RC[-22],RC[-22])" End With ' --- itemmove --- With wsItemMove .Range("A" & itemMoveStart & ":A" & itemMoveStart + nRows - 1).FormulaR1C1 = "=IF((R[-1]C)<>""م"",(R[-1]C)+1,1)" .Range("K" & itemMoveStart & ":K" & itemMoveStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R5C[-2]:RC[-2],R5C[-9]:RC[-9],RC[-9])-SUMIFS(R5C[-1]:RC[-1],R5C[-9]:RC[-9],RC[-9])" End With ' --- accmove --- With wsAccMove .Range("A" & accMoveStart & ":A" & accMoveStart + nRows - 1).FormulaR1C1 = "=ROW()-3" .Range("J" & accMoveStart & ":J" & accMoveStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R4C[-2]:RC[-2],R4C[-8]:RC[-8],RC[-8])-SUMIFS(R4C[-1]:RC[-1],R4C[-8]:RC[-8],RC[-8])" .Range("T" & accMoveStart & ":T" & accMoveStart + nRows - 1).FormulaR1C1 = "=MONTH(RC[-13])" End With ' ═══════════════════════════════════════ ' تصفية itemout ' ═══════════════════════════════════════ wsItemOut.Range("A7:H40").AutoFilter Field:=2, Criteria1:="<>" CleanUp: ' ═══════════════════════════════════════ ' إعادة الحماية والإعدادات (دائماً تنفذ) ' ═══════════════════════════════════════ On Error Resume Next wsPerform.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True wsItemMove.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True wsAccMove.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True wsAccMoveD.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True wsItemOut.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

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

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

اتفضل يا باشا LAb_Mobile.zip

جرب نحمل الملف اعتقد ممكن يقبل 2 mb

المساحة بعد الضغط = 2.05 MB المنتدى لا يقبل رفع مرفقات اكبر من 1.03 MB تقريبا مش عارف اعمل ايه بجد لو عندكم حلول هنا قول لى انا جديد عليكم

الكود سوف يعمل لكنه يعتمد على WordBasic (قديم) يقوم بترتيب نصي لا رقمي سوف أشارك معكم: ماكرو متقدم لفرز الأرقام داخل Microsoft Word بدون استخدام WordBasic مع دعم كامل للأعداد العشرية والفواصل المختلفة دعم الأعداد العشرية كشف الفاصل تلقائيا (، , ; | - :) إمكانية إدخال الفاصل يدويا خيار ترتيب تصاعدي/تنازلي التحقق من صحة البيانات (رفض الحروف) استبدال النص مباشرة داخل التحديد الكود Option Explicit Private Const MODULE_NAME As String = "SortSelectionModule" Private Const PROC_MAIN As String = "SortSelectedNumbersInWord" Private Const ERR_NO_SELECTION As Long = vbObjectError + 1001 Private Const ERR_EMPTY_TOKEN As Long = vbObjectError + 1002 Private Const ERR_NON_NUMERIC As Long = vbObjectError + 1003 Private Const ERR_NO_VALID_TOKENS As Long = vbObjectError + 1004 Private Const ERR_USER_CANCEL As Long = vbObjectError + 1005 Private Const DEFAULT_DELIMITER As String = "،" Public Sub SortSelectedNumbersInWord() Const PROC_NAME As String = PROC_MAIN On Error GoTo ErrorHandler Dim selectedText As String selectedText = Trim$(Selection.Text) Debug.Print String(50, "=") Debug.Print "INPUT TEXT = [" & selectedText & "]" If Len(selectedText) <= 1 Then Err.Raise ERR_NO_SELECTION, PROC_NAME, "يرجى تحديد قائمة أرقام مفصولة بمحدد." End If Dim autoDelim As String Dim delimiter As String autoDelim = DetectDelimiter(selectedText) autoDelim = Trim$(autoDelim) Dim respDelim As VbMsgBoxResult respDelim = MsgBox( _ "تم اكتشاف الفاصل: [" & autoDelim & "]" & vbCrLf & vbCrLf & _ "هل تريد استخدامه؟" & vbCrLf & _ "Yes = استخدام التلقائي" & vbCrLf & _ "No = إدخال فاصل يدوي", _ vbYesNoCancel + vbQuestion, "اختيار الفاصل") If respDelim = vbCancel Then Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء." End If If respDelim = vbYes And Len(autoDelim) > 0 Then delimiter = autoDelim Else delimiter = InputBox( _ "أدخل الفاصل بين الأرقام (مثل: ، أو , أو ; أو | أو -):", _ "إدخال الفاصل يدويًا", DEFAULT_DELIMITER) If Len(Trim$(delimiter)) = 0 Then Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء." End If End If Dim cleanedText As String cleanedText = Replace(selectedText, " " & delimiter & " ", delimiter) cleanedText = Replace(cleanedText, delimiter & " ", delimiter) cleanedText = Replace(cleanedText, " " & delimiter, delimiter) Debug.Print "CLEANED TEXT = [" & cleanedText & "]" Dim resp As VbMsgBoxResult resp = MsgBox("Yes = تصاعدي / No = تنازلي", vbYesNoCancel) If resp = vbCancel Then Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء." Dim isDesc As Boolean isDesc = (resp = vbNo) Dim rawTokens() As String rawTokens = Split(cleanedText, delimiter) Debug.Print "ELEMENTS COUNT = " & (UBound(rawTokens) - LBound(rawTokens) + 1) Dim values() As Double ReDim values(0 To UBound(rawTokens)) Dim i As Long, validCount As Long Dim t As String validCount = 0 For i = LBound(rawTokens) To UBound(rawTokens) t = Trim$(rawTokens(i)) Debug.Print "TOKEN[" & i & "] = [" & t & "]" If Len(t) > 0 Then If Not IsNumeric(t) Then Err.Raise ERR_NON_NUMERIC, PROC_NAME, "قيمة غير رقمية: [" & t & "]" End If values(validCount) = CDbl(t) validCount = validCount + 1 End If Next i If validCount = 0 Then Err.Raise ERR_NO_VALID_TOKENS, PROC_NAME, "لا توجد أرقام صالحة." End If ReDim Preserve values(0 To validCount - 1) If validCount > 1 Then QuickSort values, 0, validCount - 1, isDesc End If Dim output() As String ReDim output(0 To validCount - 1) For i = 0 To validCount - 1 output(i) = Trim$(CStr(values(i))) Next i Dim result As String Dim sep As String sep = delimiter & " " Dim k As Long result = output(0) For k = 1 To validCount - 1 result = result & sep & output(k) Next k With Selection .Delete .TypeText result End With Debug.Print "SORTED TEXT = [" & result & "]" Debug.Print "SORT COMPLETED SUCCESSFULLY" Debug.Print String(50, "=") Exit Sub ErrorHandler: Debug.Print String(50, "-") Debug.Print "ERROR NUMBER : " & Err.Number Debug.Print "ERROR DESC : " & Err.Description Debug.Print "PROCEDURE : " & MODULE_NAME & "." & PROC_NAME Debug.Print String(50, "-") MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical End Sub Private Function DetectDelimiter(ByVal txt As String) As String Dim arr As Variant arr = Array("،", ",", ";", "|", ":", "-") Dim i As Long For i = LBound(arr) To UBound(arr) If InStr(1, txt, arr(i)) > 0 Then DetectDelimiter = arr(i) Exit Function End If Next i DetectDelimiter = "" End Function Private Sub QuickSort(ByRef arr() As Double, ByVal low As Long, ByVal high As Long, ByVal desc As Boolean) Dim i As Long, j As Long Dim pivot As Double, tmp As Double i = low j = high pivot = arr((low + high) \ 2) Do While i <= j If desc Then Do While arr(i) > pivot: i = i + 1: Loop Do While arr(j) < pivot: j = j - 1: Loop Else Do While arr(i) < pivot: i = i + 1: Loop Do While arr(j) > pivot: j = j - 1: Loop End If If i <= j Then tmp = arr(i) arr(i) = arr(j) arr(j) = tmp i = i + 1 j = j - 1 End If Loop If low < j Then QuickSort arr, low, j, desc If i < high Then QuickSort arr, i, high, desc End Sub طريقة الاستخدام افتح Word اضغط ALT + F11 Insert >-->> Module الصق الكود ارجع وحدد الأرقام داخل المستند شغل الماكرو: SortSelectedNumbersInWord

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

ممكن لو تكرمت تضغط القاعدة وتبعتها مضغوطة