سليم حاصبيا

اذا اعجبتك الاسماء أرجو ابتكار المزيد مثلها (مع الاسماء المؤنّثة) انصح باضافة هذين السطرين على الكود ( في المكان المتاسب حسب الصورة ) لمسح التكست بوكس المناسب تحضيراً للبحث التالي

اخر اربع اسطر مسئولين عن مسح الحقول لا قيمة لهذا الأمر بالنسبة للخطأ الذي تقصده الأخت يارا

أعتقد المشكل هنا يجب تبديل الرقم 7 الى الرقم 1 عندي يعمل بشكل رائع

تم معالجة الامر تم اضافة ChecBox لاختيار حقل البحث عندها لا تجدث مشاكل 1-اختيار احد ChecBox يسمح لك بالكتابة فقط في المريع المناسب ويقوم يتفريغ المربع الآخر 2- تم اضافة ميزة جديدة بحيث يتلون السطر الذي تم اجراء التعديل عليه الملف من جديد YARA_FORM_Super..xlsm

اتبع الخطوات كما في هذه الصورة (اذا لم تظهر القائمة المنسدلة غادر الصفحة Target الى اي صفحة احرى ثم عد اليها)

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

جرب هذا الكود( بدون معادلات) Option Explicit Dim My_formula$ Dim Ar(), i% Dim Ar1() Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$4" _ And Target <> "" And Target.Count = 1 Then vl_formula End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++ Sub vl_formula() My_formula = "=IFERROR(VLOOKUP(A4,id!A4:P500,2,0),"""")" Ar = Array(2, 3, 12, 13, 15, 8, 14, _ 6, 5, 4, 7, 10, 9, 11) Ar1 = Array("C5", "G5", "C7", "E7", "G7", _ "C9", "E9", "G9", "C11", "E11", "G11", _ "C13", "E13", "C15") For i = LBound(Ar) To UBound(Ar) Range(Ar1(i)) = Evaluate(Replace(My_formula, 2, Ar(i))) Next End Sub الملف مرفق Zoukra.xlsm

قبل كل شيء ازالة الحلايا المدمجة من الملف

ممكن ان ينفع هذا التعديل YARA_FORM_New..xlsm

ممكن الحل بطريقة احرى الاسماء والارقام في الشيت Source وما تريد في الشيت Target يمكنك اخفاء الشيت Target عن الفضوليين اذا اردت واطهارها في حال تريد التعديل عليها (حذف اسماء/ زيادة اسماء / أو تعديل ارقام الخ.....) القوائم المنسدلة في الخلايا الصفراء (Target) مطاطة تستجيب لاي تغيير في البيانات و لا تذكر المكرر الا مرة واحدة وبذلك لا داعي لكتابة الاسم (منعاَ للأخطاء الاملائية وتوفيراً للوقت) بل تختاره من الفائمة المنسدلة الملف مرفق Kan3any.xlsm

توضيح

تأكد من السؤال قبل طرحه اين يوجد اكثر او أقل من 5 مرات

يمكن ان يكون المطلوب SABAH.xlsx

جرب هذا الملف (نموذج عما تريد) Ken3ani.xlsx

تم معالجة الأمر 1- للبحث * تعبئة احد التكست بوكسات الخضراء ( ليس الاثنين معاً) بما تريد البحث عته (مع مراعاة وجود ما تريد البحث عنه في الجدول بنفس العامود) اذا كان ما يبحث عنه موجوداً ( ولو في اكثر من صف) تظهر كل البيانات على الليست بوكس و اذا لم بكن موجوداً يتوقف الماكرو 2-للتعديل (او الحفظ من جديد) بعد اجراء عملية البحث * اضغط على اي صف من الليست بوكس (ما عدا الصف الأول العناوين) تظهر لك بيانات الصف الرقم القومي و رقم الكود (في المربعات الحضراء) يظهر لك المصروف القديم (المربع الأصفر الاول غير قابل للكتابة بداخله) ورقم الصف ( المريع الزهري) امّا المصروف الجديد عليك ان تحدده بنفسك (المربع الأصفر الثّاني) * اكتب الرقم الجديد للمصروف في المربع الأصفر الثاني * اضغط الزر "حفظ" عندها تنتقل المعلومات الى الشيت و الليست بوكس في نفس الوقت 3- الملف مرفق وعسى أن ينال الإعجاب YARA_FORM..xlsm

1-تغيير اسم الصفحة الأولى الى Main من اجل نسح الكود بطريقة صحيحة دون مشاكل اللغة العربية 2- الماكرو اللازم عدد (2) Option Explicit Sub From_One_to_ALL() Dim sh As Worksheet Dim Itm, m% Dim Filter_Range As Range Dim AR() Application.ScreenUpdating = False Set Filter_Range = _ Sheets("Main").Range("A1").CurrentRegion m = 1 For Each sh In Sheets If sh.Name <> "Main" Then ReDim Preserve AR(1 To m) AR(m) = sh.Name m = m + 1 End If Next For Each Itm In AR Sheets(Itm).Range("A1").CurrentRegion.Clear Filter_Range.AutoFilter 1, Sheets(Itm).Name Filter_Range.SpecialCells(12).Copy _ Sheets(Itm).Range("A1") Next Application.CutCopyMode = False If Sheets("main").AutoFilterMode Then Sheets("Main").Range("A1").AutoFilter End If Erase AR Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub Clear_all() Dim sh As Worksheet For Each sh In Sheets If sh.Name <> "Main" Then sh.Range("A1").CurrentRegion.Clear End If Next End Sub الملف مرفق GROUPING_SHEETS.xlsm

لا أفهم الغاية من جعل الاكسل غير مرئي عند فتج الملف 1- يمكنك عمل ذلك على ملفك الحاص لكن ما ذنب باقي المستخدمين لان هذا الكود يطبق على كل الــ ِApplication وبالتالي عدم القدرة على رؤية الاكسل بعد تنفيذ الماكرو حاصة اذا كان المستحدم لا يعرف كيفية اعادة ظهور الاكسل 2-لهذا السبب سوف يحذف الملف من المشاركة

تم معالجة الامر بالنسبة لزر "حفظ " والباقي فيما بعد لضيق الوقت 1- تم تحسين مظهر اليوزر من حيث التنسيق 2- لا تتم عملية الترحيل الى الشيت الا اذا كانت كل التكست بوكسات (الرقم القومى / رقم الكود/ الاسم / المصروف) غير فارغة نظهر رسالة بعدد التكست بوكسات الفارغة 3- الكود لا يسمح بتكرار البيانات (اي بيانات مكررة يقوم الكود بحذفها على الفور 4- يمكن التنقل والعمل داخل الشيت حتى ولو كان اليوزر ظاهراً 5- جربي وهاتي رأيك YARA_uSER.xlsm

جرب هذا الملف قبل تنفيذ الماكرو شاهد رؤوس الجداول في الصفحتين الثانية والثالثة و بعد تنفيذه ترى كيف اصبحت اصغط على الزر Run 1-يتم ترتيب البيانات حسب الجدول في الصفجة الأولى 2-يدرج الجدول القديم في الخلية I3 Échelles aléatoires.xlsm

يا احي ارفع نموذج بسيط من صفحتين او ثلاثة (10 صفوف على الأكثر في كل جدول) لمعالجة الامر اذ ليس من المعقول ان اقوم بانشاء ملف كما تريد و العمل عليه

انت لم تقل ان الجداول تحتوي على بيانات

انسخ النطاق من A1 الى G1 من الورقة الأولى الى كل الاوراق

بعد اذن الأخ أحمد وزيادة في اثراء الموضوع يمكن استعمال هذه المعادلة =SUMPRODUCT(0+(MOD(COLUMN($B$6:$V$6)-COLUMN($B$6)+1,3)=0),$B6:$V6) الملف مرفق Mhd_Ahm.xlsx

الأسياب في عدم الحصول على النتائج الصحيحة (الجدول يجب ان يجتوي معلومات فقط دون وجود خلايا مدمجة أو اشياء غريبة داخله) 1- وجود حلايا مدمجة داحل الجدول 2 - وجود Object غريبة (Lines ) بالاضافة الى تكست بوكس (السن في أول أكتوبر) الكود المطلوب بعد ازالة الدمج Sub from_sheet_to_other1() Dim B As Worksheet Dim MH As Worksheet Dim F_rg As Range Dim Cret$, Rot%, Rod%, m% Application.ScreenUpdating = False Set B = Sheets("البيانات") Set MH = Sheets("المحولين") If B.AutoFilterMode Then _ B.Range("A7").AutoFilter Rot = MH.Cells(Rows.Count, 1).End(3).Row Rot = IIf(Rot < 8, 11, Rot + 1) Rod = B.Cells(Rows.Count, 1).End(3).Row Set F_rg = B.Range("A7:k" & Rod) Cret = "حول" F_rg.AutoFilter 11, Cret On Error Resume Next B.Range("A8:K" & Rod).SpecialCells(12).Copy _ MH.Range("A" & Rot) B.Range("A8:K" & Rod).SpecialCells(12).EntireRow.Delete On Error GoTo 0 If B.AutoFilterMode Then _ B.Range("A7").AutoFilter Application.ScreenUpdating = True End Sub

تم التعديل على الملف بالنسبة لليوزرفوم (الملف مرفق) اتبع هذه الصور لمعرفة كيفية التعامل مع اليورز الجديد ABOU_TIBA.xlsm