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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) هذه المرة دعوة لتجربة لعبة المتاهة Maze لأول مرة من خلال آكسيس ميزات اللعبة :- التحكم الكامل من خلال الأسهم في لوحة المفاتيح . تجميع النقاط كلما التهمت الشخصية عدداً أكبر من ( ) . تخسر إذا لامست هذا الكائن في اللعبة ( ) عند طلب المساعدة باستخدام ( ) فإنه سيتم خصم 10 نقاط من رصيد النقاط التي قمت بتجميعها . اللعبة في إصدارها الأول حالياً وسيكون قريباً الكثير من المستويات في اللعب ، وهذه فقط دعوة لتجربتها وإفادتي بآرائكم حول تطويرها وتحديثها وأترككم مع ملف التحميل : Maze Game.zip

هو كذا دوما في غالب طلباته مقصر في الشرح والايضاح .. من شرحه الاخير اعتقد فهمت له ------------------------------------------------ استاذ عبدالقدوس لا يصلح تربط بين المفاتيح في الجدولين كعلاقة تم تحقيق طلبك انظر المرفق الحقل الذي اعتقد لا يمكن تكراره بين الاشخاص هو الرقم الخاص لذا اعتمدته في البحث والعد Dim i1, i2 As Integer Me.Form.Filter = "numt Like '" & textsearch & "'" Me.Form.FilterOn = True i1 = Nz(DCount("*", "tabl1", "numt = '" & textsearch & "'"), 0) i2 = Nz(DCount("*", "tabl2", "numt = '" & textsearch & "'"), 0) t1 = i1 t2 = i2 tt = i1 + i2 مثال2.rar

تفضل جرب هدا Private Sub CommandButton1_Click() Dim ws As Worksheet, src As Range, i As Long Dim arr() As Variant, columns() As Variant Dim Code As String, lastrow As Long, exists As Long Set ws = Sheets("التكويد") lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Code = Me.TextBox4.Value If Code = "" Then: MsgBox "الرجاء إدخال كود الصنف", vbExclamation, "خطأ": Exit Sub exists = WorksheetFunction.CountIf(ws.Range("a2:a" & lastrow), Code) If exists > 0 Then: MsgBox "كود الصنف موجود مسبقا", vbExclamation, "إنتبـــاه": Me.TextBox4.Value = "": Exit Sub With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set src = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) columns = Array("A", "B", "C", "D", "F", "G", "H") arr = Array(Me.TextBox4.Value, Me.TextBox1.Value, Me.TextBox7.Value, Me.TextBox2.Value, _ Me.TextBox3.Value, Me.TextBox5.Value, Me.TextBox6.Value) For i = LBound(arr) To UBound(arr) If i <= UBound(columns) Then ws.Cells(src.Row, columns(i)).Value = arr(i) End If Next i For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub عدم تكرار .xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub FindMaxClass() Dim tmp As Double Dim i&, kay&, n&, lastRow Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row tmp = Application.WorksheetFunction.Max(WS.Range("B2:B" & lastRow)) n = 0 For i = 2 To lastRow If WS.Cells(i, 2).value = tmp Then If WS.Cells(i, 1).value > n Then n = WS.Cells(i, 1).value End If End If Next i kay = n WS.Range("E1").Resize(1, 2).value = Array(kay, tmp) End Sub لتنفيد الكود مباشرة عند التغيير في أحد الأعمدة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet Set WS = Me If Not Intersect(Target, WS.Range("A:B")) Is Nothing Then If Target.Row > 1 Then Dim i As Long, kay As Long, lastRow As Long Dim a As Variant, tmp As Double lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row a = WS.Range("A2:B" & lastRow).value tmp = Application.WorksheetFunction.Max(Application.Index(a, 0, 2)) kay = 0 For i = LBound(a, 1) To UBound(a, 1) If a(i, 2) = tmp Then If a(i, 1) > kay Then kay = a(i, 1) End If End If Next i WS.Range("E1").Resize(1, 2).value = Array(kay, tmp) End If End If End Sub test1.xlsb

اتفضل طلبك لكن انصحك نصيحه لوجه الله لا تجعل اسماء الحقول فى الجداول بالعربي هتتعبك قدام test(1).rar

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

بداية يجب تفعيل هذه المكتبات لديك ..... KAN-picutre.rar

انا فتحت النموذج وشايف انك بالفعل عامل ده وجايب ليك العدد وجايب ليك البيانات وفى شريط السجلات تحت مكتوب انها 2 سجل موجود ممكن تستعرضهم فوالله ثم والله ما فهمت عليك انا حاسس ان طلبك بسيط جدا بس انا مش عارف ازاى افهم انت عاوز ايه بالظبط 😅

موضوعك غير مهيأ 1- في التقارير تريد اظهارها حسب الدرجة ، والدرجة في الجدول مدمجة ، بينما في الفورم يتم الاختيار مفرد 2- المفترض طلبك يكون حول نقطة واحدة فقط ، حتى لا يتشتت فكر من يتصدى للإجابة ملاحظة مهمة : عملك الدمج اصلا في الجدول خطأ فادح .. وانما يتم حسب الحاجة في الاستعلام او التقرير

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

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

قمت بعمل برنامج بسيط 1- اضافة بيانات المرضي 2- اضافة بيانات المعالجين 3- التعديل على بيانات المستخدمين وصلاحيات (بطريقة بسيطه لتوضيح الفكره) واضافة جديد ايضا 4- اضافة حركة او قيد او زيارة كما تحب ان تسميها 5- كشف حساب للمرضي 6- كشف حساب للمعالجين 7- لتبديل المستخدم 8- لغلق البرنامج عند تشغيل القاعده هيظهر لى نموذج الدخول (معمول بشكل بسيط ايضا) 😅 تم تسجيل 2 مستخدمين الاول اسم المستخدم 1 وكلمة السر 1 (لديه جميع الصلاحيات) الثاني اسم المستخدم 2 وكلمة السر 2 (لديه بعض الصلاحيات) نزل البرنامج وحاول اولا تشوف فكرته واذا واجهتك اى صعوبة فى فهم الية العمل اسأل هنا وهشرحلك كل شئ Clinic_001.rar

@عمر ضاحى ممنون استاذ لاتعرف كم افادني هذا الامر جزاك الله كل خير

ليس هناك مستحيل اخي @عبد الرحمن أشرف يمكننا إظافة دالة جديدة مع الحفاظ على الأولى لتتمكن من إختيار ما يناسبك الدالة الجديدة مع التفقيط Option Explicit Function CalcAgeArabic(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant Dim vYears As Integer, vMonths As Integer, vDays As Integer If IsEmpty(vDate1) Or IsEmpty(vDate2) Then CalcAgeArabic = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAgeArabic = CVErr(xlErrValue) Exit Function End If If vDate2 < vDate1 Then MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول" CalcAgeArabic = CVErr(xlErrValue) Exit Function End If vYears = Year(vDate2) - Year(vDate1) vMonths = Month(vDate2) - Month(vDate1) vDays = Day(vDate2) - Day(vDate1) If vDays < 0 Then vMonths = vMonths - 1 Dim lastMonth As Date lastMonth = DateAdd("m", -1, vDate2) vDays = Day(DateSerial(Year(lastMonth), Month(lastMonth) + 1, 1) - 1) + vDays End If If vMonths < 0 Then vYears = vYears - 1 vMonths = vMonths + 12 End If Select Case resultType Case "Days" CalcAgeArabic = NumberToArabicWords(vDays) & " يوم" Case "Months" CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور" Case "Years" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات" Case "Days and Months" CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور و " & NumberToArabicWords(vDays) & " يوم" Case "Years and Months" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور" Case "Years, Months, Days" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور و " & _ NumberToArabicWords(vDays) & " يوم" Case Else CalcAgeArabic = "صيغة الدالة غير معروفة" End Select End Function Function NumberToArabicWords(ByVal Number As Integer) As String Select Case Number Case 1: NumberToArabicWords = "واحد" Case 2: NumberToArabicWords = "اثنان" Case 3: NumberToArabicWords = "ثلاثة" Case 4: NumberToArabicWords = "أربعة" Case 5: NumberToArabicWords = "خمسة" Case 6: NumberToArabicWords = "ستة" Case 7: NumberToArabicWords = "سبعة" Case 8: NumberToArabicWords = "ثمانية" Case 9: NumberToArabicWords = "تسعة" Case 10: NumberToArabicWords = "عشرة" Case 11: NumberToArabicWords = "أحد عشر" Case 12: NumberToArabicWords = "اثنا عشر" Case 13: NumberToArabicWords = "ثلاثة عشر" Case 14: NumberToArabicWords = "أربعة عشر" Case 15: NumberToArabicWords = "خمسة عشر" Case 16: NumberToArabicWords = "ستة عشر" Case 17: NumberToArabicWords = "سبعة عشر" Case 18: NumberToArabicWords = "ثمانية عشر" Case 19: NumberToArabicWords = "تسعة عشر" Case 20: NumberToArabicWords = "عشرون" Case 21: NumberToArabicWords = "واحد وعشرون" Case 22: NumberToArabicWords = "اثنان وعشرون" Case 23: NumberToArabicWords = "ثلاثة وعشرون" Case 24: NumberToArabicWords = "أربعة وعشرون" Case 25: NumberToArabicWords = "خمسة وعشرون" Case 26: NumberToArabicWords = "ستة وعشرون" Case 27: NumberToArabicWords = "سبعة وعشرون" Case 28: NumberToArabicWords = "ثمانية وعشرون" Case 29: NumberToArabicWords = "تسعة وعشرون" Case 30: NumberToArabicWords = "ثلاثون" Case Else: NumberToArabicWords = CStr(Number) End Select End Function حساب الفرق بين تاريخين - بالتفقيط (1).xlsm

نعم أخى محمد هذا ما أقصده هناك نقطة أخيرة فى هذا الموضوع إن لم أكن مزعجاً ***** ولسنا فى عجلة من أمرنا لأنه ربما تستغرق هذة النقطة الكثير من وقتكم الثمين لتعديلها تتمثل هذة النقطة فى كيف يمكن تغيير اللغة الإنجليزية إلى اللغة العربية كما نقول باللغة العربية على سبيل المثال ومن اليمين إلى اليسار 5 سنوات و 3 شهور و 18 يوم أو ربما يوجد كود لتفقيط عدد السنوات والشهور والأيام كقولنا **** خمسة سنوات وثلاثة أشهر وثمانية عشر يوما أم تعدو هذه النقطة حُلما لى **** أرجو الإفادة وإن لم يكن أخى وحبيبى فى الله محمد فقد وفيت وكفيت وعشت وعاش المغرب الحبيب وعاشت مصر الحبيبة

من خلال الجملة الشرطية تستطيع تنفيذها يا صديقي 🤗

Private Sub Form_BeforeUpdate(Cancel As Integer) Dim t54Value As Integer Dim devValue As String Dim response As Integer t54Value = Me.t54 devValue = Me.dev ' تحقق إذا كانت قيمة t54 تساوي 6 وأيضاً إذا dev لا يحتوي على الرقم 5 If t54Value = 6 And Not devValue Like "*5" Then ' إظهار رسالة تأكيد response = MsgBox("الحقل dev يجب أن يحتوي على الرقم 5. هل ترغب في الاستمرار؟", vbYesNo + vbExclamation, "تأكيد") If response = vbNo Then ' إذا اختار المستخدم "لا"، أعد الحقل t54 إلى Null أو القيمة الافتراضية Me.t54 = Null ' أو يمكنك تعيين قيمة معينة بدلًا من Null Cancel = True ' يمنع إغلاق النموذج End If End If ' تحقق إذا كان المستخدم يحاول الخروج بدون كتابة رقم الطلب الذي يبدأ برقم 5 If devValue = "" Or Left(devValue, 1) <> "5" Then ' تعيين القيم المطلوبة Me.t54 = 1 Me.dev = "لم يتم كتابة رقم الطلب أثناء التنفيذ" ' إظهار رسالة تنبيه MsgBox "تم الغاء التحديث لم يتم كتابة رقم الطلب", vbInformation, "تنبيه" Cancel = True ' يمنع إغلاق النموذج End If End Sub شرح للمتغير عن الكود السابق. تم إنشاء شرط إضافي للتحقق إذا كان الحقل dev فارغًا أو لا يبدأ برقم 5. إذا تحقق الشرط، نقوم بتعيين t54 إلى 1 و dev إلى "لم يتم كتابة رقم الطلب أثناء التنفيذ". تظهر رسالة تنبيه تخبر المستخدم بأنه تم إلغاء التحديث. يتم تعيين Cancel إلى True لمنع إغلاق النموذج إذا كانت الشروط مستوفاة. بهذا الشكل، ستحقق ما تريده. اتمني التجربة و الرد صديقي

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة وهى تستخدم دالة AGGREGATE لتحديد آخر عمود يحتوي على قيمة غير فارغة، ومن ثم دالة INDEX لاسترجاع القيمة المطابقة. المعاداة =IFERROR( IF(A14=""; ""; INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); AGGREGATE(14; 6; COLUMN($B$2:$E$2) / (INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); 0)<>""); 1) - COLUMN($B$2) + 1) ); "بدون نتيجة") الملف اخر ادخال بالصف.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة") أو بإستخدام vba Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Code As Variant, dataA As Variant, dataB As Variant Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("A2:A9") Set rngB = Me.Range("B2:E9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo CleanExit If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then dataA = rngA.Value dataB = rngB.Value For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(dataB(tmp, col)) <> "" Then result = dataB(tmp, col) Exit For End If Next col cell.Offset(0, 1).Value = result Else Code = cell.Value cell.Resize(1, 2).ClearContents MsgBox "الكود " & Code & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp.xlsb

السلام عليكم اذاكانت الملفات المرتبطة عددها بسيط استخدم الطريقة اليدوية التالية فتح الملف الرئيسي: افتح ملف Excel الرئيسي الذي يحتوي على الروابط إلى الملفات الأخرى. تحرير الروابط: اذهب إلى علامة التبويب "البيانات" (Data) في الشريط. اضغط على "تحرير الروابط" (Edit Links) التي توجد عادة في مجموعة "الاتصالات" (Connections). تغيير مصدر الروابط: ستظهر لك نافذة تحتوي على جميع الروابط الموجودة في الملف. حدد الروابط التي تحتاج إلى تحديث، ثم اضغط على "تغيير المصدر" (Change Source). اختيار الموقع الجديد: اختر الملفات من الموقع الجديد الذي تم نقلها إليه. تحديث الروابط: بعد اختيار الملفات، اضغط على "موافق" لتحديث الروابط إلى الموقع الجديد. اذ كانت الروابط كثيرة فاستخدم الكود التالى Sub UpdateLinks() Dim OldLink As String Dim NewLink As String Dim LinkArray As Variant Dim i As Integer ' الرابط القديم OldLink = "C:\المسار_القديم\" ' الرابط الجديد NewLink = "C:\المسار_الجديد\" LinkArray = ActiveWorkbook.LinkSources(Type:=xlExcelLinks) If Not IsEmpty(LinkArray) Then For i = LBound(LinkArray) To UBound(LinkArray) If InStr(LinkArray(i), OldLink) > 0 Then ActiveWorkbook.ChangeLink Name:=LinkArray(i), NewName:=Replace(LinkArray(i), OldLink, NewLink), Type:=xlExcelLinks End If Next i End If MsgBox "تم تحديث الروابط بنجاح!", vbInformation End Sub قم بتعديل المسارات (OldLink و NewLink) حسب الموقع القديم والجديد للملفات.

أخي @صباح2024 إدا كنت قد إستوعبت طلبك سنقوم بتعديل الكود بطريقة مختلفة لنتمكن من تنفيد المطلوب بشكل دقيق لان دمج الاكواد على Private Sub Worksheet_Change(ByVal Target As Range) والإشتغال عليها مباشرة من شأنه أن يسبب لك عدة مشاكل خاصة انك ترغب بتحديث البيانات عند كل تغيير على اي خلية لنفترض أنك قمت باسـتدعاء اي اسم مثلا من الطبيعي ان البيانات السابقة مختلفة بمجرد استدعائها سيتم نسخها للاعمدة الخاصة بالاسم الدي تم اختياره مما سيسبب لك تلف وتعارض في البيانات اسف على الإطالة لاكن لابد من توضيح الفكرة ( اليك ما تم الإشتغال عليه) 1) جلب البيانات من ورقة السجل الى ورقة استدعاء بشرط الإسم 2) تحديث البيانات عند التغيير في أي خلية من الخلايا التي تم تمييزها باللون الأصفر على ورقة استدعاء على الأعمدة المناسبة في ورقة السجل مع مراعات الإسم 3) تم اظافة كود لإنشاء قائمة منسدلة ديناميكية بالأسماء الفريدة من العمود B ( ورقة السجل) بداية من الصف 2 تلقائيا في خلية الإسم (B6) ورقة استدعاء الأكواد المستخدمة : Public Property Get WS() As Worksheet Set WS = Sheets("استدعاء") End Property Public Property Get dest() As Worksheet Set dest = Sheets("السجل") End Property ' خلية الإسم Public Function Clé() As String Clé = WS.Range("B6").Value End Function 'نطاق البحث Public Function rng() As Range Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) End Function '======================== ' جلب البيانات من ورقة السجل إلى ورقة "استدعاء" Sub Fetch_data() Dim data As Variant, i As Long, tmp As Range Application.ScreenUpdating = False On Error GoTo CleanExit Set tmp = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If For i = 0 To 3 data = dest.Range(tmp.Offset(0, 1 + (i * 9)), tmp.Offset(0, 9 + (i * 9))).Value WS.Range("A" & (9 + (i * 3)) & ":I" & (9 + (i * 3))).Value = data Next i CleanExit: Application.ScreenUpdating = True End Sub '======================== ' تحديث البيانات من ورقة استدعاء الى ورقة السجل Sub Update_data() Dim tmp As Range, cnt() As Variant, OnRng As Range Dim ColArr() As Long, j As Long, i As Long Set OnRng = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If OnRng Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim Irow As Long Irow = OnRng.Row ReDim ColArr(0 To 35) For j = 0 To 35 ColArr(j) = j + 3 Next j ReDim cnt(UBound(ColArr)) For i = 0 To UBound(cnt) cnt(i) = WS.Cells(9 + (i \ 9) * 3, 1 + (i Mod 9)).Value Next i For i = 0 To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub '======================== ' إضافة قائمة منسدلة بالأسماء المتوفرة في ورقة "السجل" Sub Add_listeDéroulante() Dim lr As Long, arr() As String, r As Range, i As Long Dim cnt As New Collection, Names As Range lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In rng If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set Names = WS.Range("B6") With Names.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As Range, cntArr As Range Set Clé = WS.Range("B6") If Clé.Value = "" Then Exit Sub If Target.Address = Clé.Address Then On Error GoTo ErrorHandler Fetch_data Exit Sub End If ' عناوين الخلايا المستهدفة Set cntArr = Me.Range("A9:I9, A12:I12, A15:I15, A18:I18") If Not Intersect(Target, cntArr) Is Nothing Then On Error GoTo ErrorHandler Update_data Exit Sub End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description On Error GoTo 0 End Sub وأي إستفسار سنكون دائما سعداء بمساعدتك تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm