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

المشكلة في الفراغات وبما ان الترقيم به ارقام ونصوص فيكون التنسيق نص كما تم وضع كود لازالة الفراغات الدالة =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

الاجابة بواسطة الذكاء الاصطناعي يمكنك ربط جداول Excel الموجودة على OneDrive بقاعدة بيانات Access باتباع الخطوات التالية: فتح قاعدة بيانات Access: افتح قاعدة البيانات التي تريد ربط جداول Excel بها. استيراد البيانات من Excel: اذهب إلى علامة التبويب “بيانات خارجية” في شريط الأدوات. اختر “Excel” من مجموعة “استيراد وربط”. تحديد ملف Excel: في نافذة “الحصول على بيانات خارجية - Excel”، انقر على “استعراض” لتحديد ملف Excel الموجود على OneDrive. أدخل مسار الملف أو انسخه من OneDrive. اختيار طريقة الربط: اختر “ربط بمصدر البيانات عن طريق إنشاء جدول مرتبط” ثم انقر على “موافق”. تحديد ورقة العمل: اختر ورقة العمل التي تحتوي على البيانات التي تريد ربطها بقاعدة بيانات Access. إكمال الربط: اتبع التعليمات التي تظهر على الشاشة لإكمال عملية الربط. بهذه الطريقة، ستتمكن من الوصول إلى جداول Excel من داخل Access والعمل عليها كما لو كانت جزءًا من قاعدة البيانات. إ

السلام عليكم اعدرنى على التاخير test (1) (1).xls

وعليكم السلام ورحمة الله وبركاته جزاك الله كل خير على طيبتك وحسن تربيتك ونبل اخلاقك بارك الله فيك ورحم الله والديك

حسب فهمى للطلب =IF(G3="";"";INT(DATEDIF(G3;TODAY();"m")/4)*10) TESTT.xlsx

تم التعديل test (1).xls

تم التعديل يمكن الاختيار بالفارة ويمكنك الخروج عن طريق علامة × في الفورم test.xls

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

اسعدنى ما قلت , بالتوفيق

السلام عليكم جرب المرفق الاختيار من القائمة بالضغط مرتين على العتصر المختار واذا كان الرقم غير موجود تاتى رسالة بذلك بالتوفيق واي ملاحظات لا حرج في ذلك test.xls

اين تريد النتائج في اي صفحة واي مدى

بالنسبة تكست 18 و19 اذهب الى لوحة التحكم - الساعة والمنطقة - المنطقة - ثم كما بالصورة الملف اظهار نتائج البحث في اللستبوكس1.xlsm

وعليكم السلام دالة recherchv لا اجيدها واعتقد انها فرنسية ولكن قمت بحل اخر وان لم يكن مناسبا لك قم بفتح موضوع جديد واطلب فيه دالة recherchv وستجد من الخبراء من يقوم بذلك تحياتي اسم المقاطعة.xlsb

السلام عليكم تم تعديل النقطتين الاولى والثانية والثانية كان سببها اكثر من رقم حساب مكرر النقطتان 3 4 ان شاء بعد العودة من العمل جرب المرفق ولاحرج في اي ملاحظة تقبل تحياتي اظهار نتائج البحث في اللستبوكس1.xlsm

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

تعديل للملف اظهار نتائج البحث في اللستبوكس.xlsm

هو كود صغير يقوم بالمهمة وقبل الحذف يسالك هل تريد الحذف ام لا مع عدد من تم حذفهم الكود Sub DeleteRows() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim deleteCount As Long Dim response As VbMsgBoxResult Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row deleteCount = 0 response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If ws.Cells(i, 2).Value <> "" And ws.Cells(i, 3).Value <> "" Then ws.Rows(i).Delete deleteCount = deleteCount + 1 End If Next i MsgBox deleteCount & " صفوف تم حذفها.", vbInformation, "عملية الحذف" Else MsgBox "تم إلغاء عملية الحذف.", vbInformation, "إلغاء" End If End Sub الملف حذف اسماء من استلمو الاول والثاني.xlsm

وعليكم السلام لم اتمكن من تحميل الملف يستحسن اعادة رفعه مرة اخرى

قمت بطباعة الورقة وامورها 100% الاوفيس لدي 2016 وندوز 10 جرب على اكثر من جهاز

كما تشاهد في الصورة وافتح ملف PDF المرفق في مشاركتى السابقة الحدود متساوية بالكامل

السلام عليكم المعادلة =HYPERLINK("#'" & A2 & "'!A1"; A2) الملف ارتباط تشعبى شيت بخلية.xlsx