عبدالله بشير عبدالله

السلام عليكم حقيقة كود الفاضل محمد هشام حاولت فهمه لم اتمكن من استيعابه بالكامل لانى حاولت التعدبل فيه بسبب الصورة المتحركة عند اختياره شهر 12 ظهر بالصورة بداية الشهر الاحد يوافق يوم 8 وحسب التقوبم الشهر يبدأ يوم 1 طبعا لم اجرب الملف كما قلت حسب الصورة المتحركة تأمل من استاذنا الفاضل تعدبل الكود للاستفاذة ربما التعديل التالى لاختيار التاريخ يناسبك بمكن تعديل السنوات من الكود أيام الشهر من يوم محدد - vba (1).xlsm

وعليكم السلام ورحمة الله وبركاته الاستاذ محمد هشام في المشاركة السابقة اخبرك (في حالة كنت تستخدم إصدار قديم لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة) حسب ملفك الحالى كود في حدث الورقة كلما تم التغيير في M2 يتم التغيير في الاعمدة الملف أيام الشهر من يوم محدد - vba (1).xlsm

السلام عليكم بعد اذنكما محاولة حسب فهمى لطلبك فى الملف المرفق باول مشاركة عن طربق الكود في حدث الورقة الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("C2")) Is Nothing Then Me.Range("A5:B" & Me.Rows.Count).ClearContents Dim monthYear As Date Dim firstDay As Date Dim lastDay As Date Dim currentDay As Date Dim outputRow As Long monthYear = Me.Range("C2").Value firstDay = DateSerial(Year(monthYear), Month(monthYear), 1) lastDay = DateSerial(Year(monthYear), Month(monthYear) + 1, 0) Dim startDay As Date startDay = firstDay Do While Weekday(startDay, vbSunday) <> vbSunday startDay = startDay + 1 Loop outputRow = 5 For currentDay = startDay To lastDay If Weekday(currentDay, vbSunday) <= 5 Then Me.Cells(outputRow, 2).Value = currentDay Select Case Weekday(currentDay, vbSunday) Case 1 Me.Cells(outputRow, 1).Value = "الأحد" Case 2 Me.Cells(outputRow, 1).Value = "الإثنين" Case 3 Me.Cells(outputRow, 1).Value = "الثلاثاء" Case 4 Me.Cells(outputRow, 1).Value = "الأربعاء" Case 5 Me.Cells(outputRow, 1).Value = "الخميس" End Select outputRow = outputRow + 1 End If Next currentDay End If End Sub الملف أيام الشهر من يوم محدد.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub ExtractAbsentees() Dim ws As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim outputRow As Long Set ws = ThisWorkbook.Sheets("SHEET1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column outputRow = 5 For i = 5 To lastRow For j = 4 To lastCol If ws.Cells(i, j).Value = "A" Then ws.Cells(outputRow, 15).Value = ws.Cells(i, 2).Value ws.Cells(outputRow, 16).Value = ws.Cells(4, j).Value outputRow = outputRow + 1 End If Next j Next i End Sub الملف الغياب.xlsb

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة وهى تستخدم دالة 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

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

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx

الكود يرتب ابجدي ويحذف التكرار Private Sub UserForm_Initialize() Dim ws As Worksheet Dim rng As Range Dim data As Variant Dim sortedData As Variant Dim uniqueData As Collection Dim i As Long, j As Long Dim temp As Variant Set ws = ThisWorkbook.Sheets("Sheet3") Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) data = rng.Value ReDim sortedData(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) sortedData(i, 1) = data(i, 1) Next i For i = 1 To UBound(sortedData, 1) - 1 For j = i + 1 To UBound(sortedData, 1) If sortedData(i, 1) > sortedData(j, 1) Then temp = sortedData(i, 1) sortedData(i, 1) = sortedData(j, 1) sortedData(j, 1) = temp End If Next j Next i Set uniqueData = New Collection On Error Resume Next For i = 1 To UBound(sortedData, 1) uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1)) Next i On Error GoTo 0 With Me.ComboBox1 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With With Me.ComboBox2 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With End Sub الملف ترتيب البيانات ابجديا.xlsm

وعليكم السلام ورحمة الله وبركاته جرب الملف الكود Sub CalculateNetValues() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim dict As Object Dim key As Variant Dim totalValue As Double Dim expenseValue As Double Dim netValue As Double Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") For i = 4 To lastRow If Not dict.exists(ws.Cells(i, "C").Value) Then dict.Add ws.Cells(i, "C").Value, ws.Cells(i, "D").Value Else dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) + ws.Cells(i, "D").Value End If Next i For i = 4 To lastRow If dict.exists(ws.Cells(i, "C").Value) Then If IsNumeric(ws.Cells(i, "J").Value) Then dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) - ws.Cells(i, "J").Value End If End If Next i netValue = 0 For Each key In dict.keys netValue = netValue + dict(key) Next key ws.Range("O5").Value = netValue End Sub الملف تجارب اجمالى العهدة.xlsb

تفضل جرب الملف ذكور ثم انات 1.xlsb

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

وفيك بارك الله ,اعلم ذلك والا ما قمت انت والاستاذ محمد صالح يكفى وزيادة لك وافر التقدير الاحترام

يفترض فتح موضوع جديد ولكن بما انه نفس الملف مع تعديل في نفس الكود ذكور ثم انات.xlsb

السلام عليكم ورحمة الله وبركاتة تحياتى للاستاتذة الافاضل محمد صالح ومحمد هشام و حسين التجدى اعتقد ان صاحب الموضوع لم يكن طلبه الذكور في عمود والاناث في العمود المقابل بل بربد المزج بينهما في نفس العمود اول اسم ذكر الصف الذي يليه انثى وهكذا وهذا ما فهمته من ملفه المرفق حيث يوجد في طلبه الذكور في صف والاناث في صف على كل حال اذا كان فهمى للموضوع صحيحا فالكود التالى يلبى الطلب ان شاء الله وان كان فهمى للامر غير ذلك فعذرا من الجميع الكود Sub TransferStudentsByGenderAlternate22() Dim wsData As Worksheet Dim wsList As Worksheet Dim lastRow As Long Dim selectedClass As String Dim i As Long Dim rowMale As Long, rowFemale As Long Dim maleList As Collection, femaleList As Collection Dim studentName As String Dim studentGender As String Dim studentData As String Dim maxRows As Long Dim lastNumber As Long Dim currentNumber As Long Set wsData = ThisWorkbook.Sheets("قاعدة البانات") Set wsList = ThisWorkbook.Sheets("قوائم الفصول") selectedClass = wsList.Range("D5").Value lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).row Set maleList = New Collection Set femaleList = New Collection For i = 8 To lastRow If wsData.Cells(i, 3).Value = selectedClass Then ' التحقق من الفصل studentName = wsData.Cells(i, 2).Value studentGender = wsData.Cells(i, 4).Value studentData = wsData.Cells(i, 13).Value ' العمود M If studentGender = "ذكر" Then maleList.Add Array(studentName, studentData) ElseIf studentGender = "انثى" Then femaleList.Add Array(studentName, studentData) End If End If Next i rowMale = 7 rowFemale = 8 maxRows = 34 wsList.Range("B7:F40").ClearContents For i = 1 To Application.WorksheetFunction.Max(maleList.Count, femaleList.Count) If rowMale <= 40 Then If i <= maleList.Count Then wsList.Cells(rowMale, 2).Value = maleList(i)(0) wsList.Cells(rowMale, 3).Value = maleList(i)(1) rowMale = rowMale + 2 End If If i <= femaleList.Count And rowFemale <= 40 Then wsList.Cells(rowFemale, 2).Value = femaleList(i)(0) wsList.Cells(rowFemale, 3).Value = femaleList(i)(1) rowFemale = rowFemale + 2 End If ElseIf rowMale > 40 Then If i <= maleList.Count Then wsList.Cells(rowMale - 34, 5).Value = maleList(i)(0) wsList.Cells(rowMale - 34, 6).Value = maleList(i)(1) rowMale = rowMale + 2 End If If i <= femaleList.Count Then wsList.Cells(rowFemale - 34, 5).Value = femaleList(i)(0) wsList.Cells(rowFemale - 34, 6).Value = femaleList(i)(1) rowFemale = rowFemale + 2 End If End If Next i currentNumber = 1 For i = 7 To 40 If wsList.Cells(i, 2).Value <> "" Then wsList.Cells(i, 1).Value = currentNumber currentNumber = currentNumber + 1 End If Next i For i = 7 To 40 If wsList.Cells(i, 5).Value <> "" Then wsList.Cells(i, 4).Value = currentNumber currentNumber = currentNumber + 1 End If Next i End Sub الملف Microsoft Excel Worksheet جديد (3).xlsb

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

وعليكم السلام ورحمة الله وبركاته نعم، يمكنك ربط ملف Excel بملف Access عند عمل تحديث بيانات أو اضافة في ملف اكسل تنتقل هذه االتحديثات أو الاضافات أو التغييرات الى ملف اكسس اتبع الخطوات في الصور قاعدة بيانات.zip اكسل.xlsm

احد المواقع افادتي بالاني :- عندما تقوم بتنزيل ملف Excel من OneDrive وتحفظه على جهازك كملف محلي، فإن ارتباطه بالملف الأصلي على OneDrive سينقطع. يعني أن أي تغييرات تطرأ على الملف الموجود على OneDrive لن تنعكس في النسخة التي قمت بتنزيلها على جهازك. الحفاظ على الارتباط بالملف الأصلي على OneDrive للإبقاء على الارتباط بالملف الأصلي الموجود على OneDrive، يمكنك اتباع الطرق التالية: استخدام رابط المشاركة: بدلاً من تحميل الملف، يمكنك استخدام رابط المشاركة المباشر للملف في OneDrive. هذا سيمكنك من ربط الجدول في Access مباشرةً دون الحاجة لتنزيله. يمكنك استخدام الرابط كما يلي: في Access، عند إنشاء جدول مرتبط، أدخل رابط المشاركة مباشرة في مربع اسم الملف. تأكد من أن الرابط يؤدي مباشرةً إلى الملف (يجب أن يكون رابط التحميل وليس رابط العرض). مزامنة المجلد المشترك: كما ذكرت سابقًا، يمكنك إضافة المجلد المشترك إلى OneDrive الخاص بك، مما يسمح لك بمزامنة المحتويات مع جهاز الكمبيوتر. بمجرد إضافة المجلد، سيظهر في مجلد OneDrive المحلي، وسيظل مرتبطًا بالملف على OneDrive. إذا تم تحديث الملف على OneDrive، فإن النسخة المحلية ستتزامن تلقائيًا. خلاصة إذا قمت بتحميل الملف: الارتباط سيفقد، وأي تغييرات على OneDrive لن تؤثر على النسخة التي لديك محليًا. إذا استخدمت رابط المشاركة أو مزامنة المجلد: ستحافظ على الارتباط، وأي تغييرات في الملف على OneDrive ستظهر تلقائيًا في Access. إذا كنت بحاجة إلى الحفاظ على الارتباط، فالأفضل هو استخدام رابط المشاركة أو مزامنة المجلد موقع اخر افادني للأسف، بعد تنزيل الملف من OneDrive إلى جهاز الكمبيوتر، لن يبقى مرتبطًا تلقائيًا بملف Excel الأساسي الموجود على OneDrive. ستحتاج إلى إعادة إنشاء الرابط يدويًا بعد تنزيل الملف. إليك كيفية القيام بذلك: فتح الملف الذي تم تنزيله: افتح ملف Excel الذي قمت بتنزيله على جهاز الكمبيوتر. إعادة إنشاء الرابط: اذهب إلى علامة التبويب “بيانات” (Data) في Excel. اختر “تحرير الروابط” (Edit Links) من مجموعة “الاتصالات” (Connections). في نافذة “تحرير الروابط”، اختر الرابط الذي تريد تحديثه، ثم انقر على “تغيير المصدر” (Change Source). حدد ملف Excel الأساسي الموجود على OneDrive كمصدر جديد. حفظ التغييرات: بعد تحديث الروابط، احفظ الملف. بهذه الطريقة، ستتمكن من الحفاظ على الروابط بين الملفات حتى بعد تنزيلها. إذا كنت بحاجة إلى مزيد من المساعدة أو لديك أي استفسارات أخرى، لا تتردد في طرحها! 😊 1: Fix broken links to data - Microsoft Support 2: Problem with excel workbook links on onedrive - Microsoft Community

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

وعليكم السلام ورحمة الله وبركاته بعد اذن الاستاذ حجازى واثراءا للموضوع واظافة وهي عدم السماح للصف الذي به بيانات باظافة صف فارغ الا مرة واحدة الكود Private Sub CommandButton1_Click() Dim i As Long Dim ws As Worksheet Dim lastRow As Long Dim nextRowData As Long Set ws = ActiveSheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False lastRow = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ SearchFormat:=False).Row For i = lastRow To 2 Step -1 If Application.WorksheetFunction.CountA(ws.Rows(i)) > 0 Then nextRowData = Application.WorksheetFunction.CountA(ws.Rows(i + 1)) If nextRowData > 0 Then ws.Rows(i + 1).Insert Shift:=xlDown End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub الملف إضافة صف فارغ.xlsm

قدمت له استفسارك فاجابنى لإدخال جداول من ملف Excel الموجود في OneDrive كمصدر مرتبط في Microsoft Access، يمكنك اتباع الخطوات التالية: 1. الحصول على رابط المشاركة للملف: قم بفتح OneDrive عبر المتصفح. اذهب إلى الملف الذي شارك به صديقك. انقر على زر المشاركة (Share) واختر "نسخ الرابط" (Copy link) ليكون لديك رابط مباشر للملف. 2. تحميل الملف إلى جهاز الكمبيوتر: نظرًا لأن الملف لا يظهر في مجلد OneDrive على الكمبيوتر، يمكنك تحميله مباشرةً من الرابط الذي حصلت عليه. افتح الرابط في المتصفح. قم بتحميل الملف على جهاز الكمبيوتر. 3. استيراد الجداول إلى Access: افتح Microsoft Access. أنشئ قاعدة بيانات جديدة أو افتح قاعدة بيانات موجودة. اذهب إلى علامة التبويب "خارج البيانات" (External Data). اختر "Excel" من مجموعة استيراد & ربط. في مربع الحوار الذي يظهر، اختر "ربط إلى المصدر" (Link to the data source by creating a linked table). ابحث عن ملف Excel الذي قمت بتحميله، وحدده. اتبع التعليمات لإكمال عملية الربط. اختر الجداول التي ترغب في ربطها. 4. تأكيد الربط: بعد الانتهاء من عملية الربط، ستظهر الجداول في Access كجداول مرتبطة، ويمكنك استخدامها كما لو كانت جداول محلية.

المشكلة في الفراغات وبما ان الترقيم به ارقام ونصوص فيكون التنسيق نص كما تم وضع كود لازالة الفراغات الدالة =IFERROR(VLOOKUP(P5; 'صفحه البيانات'!$E$2:$F$10000; 2; FALSE); "غير موجود") الملف شرح الاسباب (1).xlsx

الملف السابق به تعديل المدى في الشيتات الثلاتة الاولى الكود السابق يبذأ من الصف 12 والصحيح انه 9 على كل حال الملف المرفق الحالى به زرين الاول الكود الاول مع التعديل والزر الاخر الكود بالمصفوفة وكلاهما سريعين جدا ترحيل الدرجات1.xlsm

وفيك بارك الله

وعليكم السلام ورحمة الله وبركاته حسب فهمي لطلبك الكود Sub FilterAndCopyData() Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, wsDest As Worksheet Dim searchValue As String Dim rng As Range, cell As Range Dim lastRow As Long, destRow As Long Dim serialNumber As Long Set ws1 = ThisWorkbook.Sheets("SHEET1") Set ws2 = ThisWorkbook.Sheets("SHEET2") Set ws3 = ThisWorkbook.Sheets("SHEET3") Set wsDest = ThisWorkbook.Sheets("SAAD") wsDest.Range("C13:R" & wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row).ClearContents searchValue = wsDest.Range("N7").Value destRow = 13 serialNumber = 1 For Each ws In Array(ws1, ws2, ws3) lastRow = ws.Cells(ws.Rows.Count, "P").End(xlUp).Row Set rng = ws.Range("P12:P" & lastRow) For Each cell In rng.Cells If cell.Value = searchValue Then wsDest.Cells(destRow, "C").Value = serialNumber wsDest.Cells(destRow, "F").Value = cell.Offset(0, -10).Value wsDest.Cells(destRow, "J").Value = cell.Offset(0, -6).Value wsDest.Cells(destRow, "L").Value = cell.Offset(0, -4).Value wsDest.Cells(destRow, "M").Value = cell.Offset(0, -3).Value wsDest.Cells(destRow, "P").Value = cell.Value wsDest.Cells(destRow, "Q").Value = cell.Offset(0, 1).Value wsDest.Cells(destRow, "R").Value = cell.Offset(0, 2).Value destRow = destRow + 1 serialNumber = serialNumber + 1 End If Next cell Next ws End Sub الملف ترحيل الدرجات1.xlsm

تفضل شرح الكود اما اذا تم اظافة اعمدة فربما شرح الكود بقيدك بطريقة التعديل او يمكنك حينها فنح موضوع جديد بالمنتدى وتقديم سؤالك بالتوفيق Private Sub Worksheet_Change(ByVal Target As Range) ' تعريف المتغيرات Dim wsRes As Worksheet ' ورقة العمل "res" Dim wsMokata As Worksheet ' ورقة العمل "mokata" Dim districtNumber As String ' الرقم المدخل في العمود F Dim lastRowMokata As Long ' آخر صف يحتوي على بيانات في عمود A في ورقة "mokata" Dim dataRange As Range ' النطاق الذي سيتم البحث فيه عن الرقم المدخل Dim foundCount As Integer ' عداد لعدد المرات التي يظهر فيها الرقم المدخل Dim cell As Range ' متغير ليمثل كل خلية في نطاق البحث ' ربط المتغيرات بأوراق العمل Set wsRes = ThisWorkbook.Sheets("res") Set wsMokata = ThisWorkbook.Sheets("mokata") ' يتم تجاهل الأخطاء لمنع تعطل الكود في حال حدوث خطأ On Error Resume Next ' التحقق مما إذا كانت الخلية التي تم تغييرها هي في العمود F من ورقة "res" If Not Intersect(Target, wsRes.Range("F:F")) Is Nothing Then districtNumber = Trim(CStr(Target.Value)) ' الحصول على الرقم المدخل مع إزالة المسافات الفارغة 'f اً إذا تم مسح الخلية في العمود، يتم مسح المحتويات في الأعمدة المجاورة (G, H, I) If districtNumber = "" Then Target.Offset(0, 1).Resize(1, 3).ClearContents Else ' تحديد آخر صف يحتوي على بيانات في عمود A في ورقة "mokata" lastRowMokata = wsMokata.Cells(wsMokata.Rows.Count, "A").End(xlUp).Row ' تحديد نطاق البحث عن الرقم المدخل Set dataRange = wsMokata.Range("A5:A" & lastRowMokata) foundCount = 0 ' تهيئة عداد المرات التي يظهر فيها الرقم المدخل ' البحث في النطاق عن الرقم المدخل وعدّ المرات التي يظهر فيها For Each cell In dataRange If Trim(CStr(cell.Value)) = districtNumber Then foundCount = foundCount + 1 End If Next cell ' إذا تم العثور على الرقم مرة واحدة فقط If foundCount = 1 Then For Each cell In dataRange ' العثور على الصف الذي يحتوي على الرقم المدخل If Trim(CStr(cell.Value)) = districtNumber Then ' نقل البيانات من الأعمدة 2, 3, 4 في ورقة "mokata" إلى الأعمدة G, H, I في ورقة "res" Target.Offset(0, 1).Value = wsMokata.Cells(cell.Row, 2).Value ' العمود G Target.Offset(0, 2).Value = wsMokata.Cells(cell.Row, 3).Value ' العمود H Target.Offset(0, 3).Value = wsMokata.Cells(cell.Row, 4).Value ' العمود I Exit For ' الخروج من الحلقة بعد العثور على القيمة End If Next cell ' إذا تم العثور على الرقم أكثر من مرة ElseIf foundCount > 1 Then Dim districtList As String ' سلسلة لتخزين القيم المرتبطة بالرقم المدخل districtList = "" ' جمع القيم المرتبطة بالرقم المدخل For Each cell In dataRange If Trim(CStr(cell.Value)) = districtNumber Then districtList = districtList & wsMokata.Cells(cell.Row, 4).Value & "," ' إضافة القيمة إلى السلسلة End If Next cell ' إذا تم العثور على قيم، يتم إعداد واجهة المستخدم (UserForm) لعرض هذه القيم If Len(districtList) > 0 Then districtList = Left(districtList, Len(districtList) - 1) ' إزالة الفاصلة الزائدة في نهاية السلسلة UserForm1.ListBox1.Clear ' مسح القائمة السابقة في ListBox UserForm1.ListBox1.List = Split(districtList, ",") ' تقسيم السلسلة ووضع القيم في ListBox ' ربط الخلية التي تم تغييرها مع النموذج Set UserForm1.TargetCell = Target UserForm1.Show ' عرض النموذج للمستخدم لاختيار قيمة End If Else ' إذا لم يتم العثور على الرقم، يتم عرض رسالة تحذير MsgBox "لا توجد بيانات مرتبطة بهذا الرقم.", vbExclamation End If End If End If End Sub