كل الانشطه

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

كودعمل دوائر حول الرقم فقط وليس داخل الخلية ولاتتغير حجمها مهما تغير ارتفاع الصف او اتساع العمود دائرة حول الرقم.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

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

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

شوف انا حليت المشكلة وغير قادر على رفع مرفق للاسف قيود المنتدى فى الحجم للملفات قليلة جدا جدا جدا افتح الجدول : Tbl_Mobile اضف حقل باسم : PCode الخصائص: حقل رقم - مفهرس ولا يقبل التكرار اضف له على سبيل المثال الرقم : 5 مثلما كنت تستخدم فى حقل اسم المريض وامسح حقل اسم المريض ده اساسا الان توجه الى النموذج : Lab_Mobile فى وضع التصميم فى عندك مربع نص باسم : المعرف وهو مرتبط بحقل باسم : ID وذلك الحقل غير موجود اساسا فى الجدول عير اسم مربع النص الى : PCode اجعل مصدر بيانات مربع النص الحقل الرقمى الجديد اللى انشأته فى الجدول : PCode الان اذهب الى تصميم النموذج : Laboratory وافتح الماكرو المضمن فى زر الامر وفى الخانة الخاصة بالشرط لذلك الماكرو اضف له ذلك الشرط : [PCode]=[Forms]![Laboratory]![PCode] وبس كده احفظ العمل وافتحه فى وضع العرض العادى اذهب للمريض صاحب الكود رقم 5 واضغط على الزر تجد انه تم حل المشكلة ملحوظة مهمة جدا جدا جدا انا جاوبت على سؤالك بالتمام على قدر السؤال انت تريد فتح النموذج على بيانات موجودة داخل الجدول و النموذج الخاصيين ببيانات الهاتف للمرضى بالفعل وليس اضافة بيانات فى حالة عدم وجود بيانات

بماذا يرتبط الجدول Tbl_Lab_All مع الجدول Tbl_Mobile ؟ إذا كان عن طريق إسم المريض فأنصحك التراجع من الان فمجرد إضافة همزة لإسم المريض أو تبديل التاء المربوطة بالهاء سيتم إعتباره مريض آخر لذلك من الأفضل إنشاء جدول خاص لبيانات المريض يتم فيه إدخال أي بيانات شخصية تخص المريض (رقم المريض - إسم المريض - تاريخ الميلاد - العنوان .... إلخ) ثم ربط هذا الجدول مع الجدولين Tbl_Lab_All و Tbl_Mobile بحقل رقم المريض