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

السلام عليكم 🙂 هذه طريقتي لتفكيك الحقل الى حقول 🙂 نأخذ المرفق كالمثال من هذا الرابط : . هكذا تبدو السجلات ، بالعين المجردة : . والمطلوب ان نقسم بيانات السجل الواحد الى: الاسم ورقم التسلسل (وخلينا نستخدم السجل الاول كمثال) ، ونريد النتيجة تكون : . هناك طريقتين لفرز هذه البيانات : عن طريق كود ليقرأ الحروف/الارقام/العلامات واحدا واحدا ، ثم بوضع شروط اذا جصلنا على رقم ، فنتوقف ونحفظ الجزء الاول ، ثم نواصل ... ، وهذه العملية مرهقة وتحتاج الى تفاصيل كثيرة ، عن طريق الكود ، ولكن بإستخدام الدالة Split ، ويشترط فيها ان نعرف اين (بعد اي حرف/رقم/علامات) نقسم السطر ، ولنسمية شرط القطع . سنتعامل مع الطريقة الثانية وهي الاسهل 🙂 لمعرفة شرط القطع ، يمكننا ان نتعامل مع الحروف/الارقام/العلامات مباشرة ChrW ، او نتعامل مع ارقام هذه (الحروف/الارقام/العلامات) AscW ، وانا لا استغني عن هذه الصورة المرفقة لعملي ، الحرف Chr ، ومقابله رقمه Dec : . وبالنسبة للحروف العربية ، هذا رابطها : https://sites.psu.edu/symbolcodes/languages/mideast/arabic/arabicchart/ او https://www.ssec.wisc.edu/~tomw/java/unicode.html#x0600 وقد قمت باخذ البيانات من الموقع ورتبتها في صفحة واحد : فمثلا اول حروف اسم ابراهيم : ا = 1575 ، ب = 1576 ، ر = 1585 ، بمعنى AscW(ا) = 1575 , AscW(ب) = 1576 , AscW(ر) = 1585 والعكس يكون ChrW(1575) = ا , ChrW(1576) = ب , ChrW(1585) = ر . للحصول على الاسم ، نريد ان يكون لدينا شرط القطع بعد الاسم وقبل بداية الرقم (اي في المنطقة 1) ، للحصول على التسلسل ، نريد ان يكون لدينا شرط القطع بعد التسلسل وقبل بداية الاسم التالي (اي في المنطقة 2) ، لمعرفة شرط القطع يجب علينا ان نحلل البيانات التي يراها الكمبيوتر ، وذلك بتحويل الحروف/الارقام/العلامات الى AscW ، هذا الكود يقوم بهذه العملية: Public Function Split_Names() Dim rst As DAO.Recordset Dim x() As String Dim i As Long Dim a As String Set rst = CurrentDb.OpenRecordset("Select * From MyTxt_from_pdf") Do Until rst.EOF For i = 1 To Len(rst!Field1) a = Mid(rst!Field1, i, 1) 'الحروف/الارقام/العلامات a = a & "(" & AscW(a) & ") " 'رقمها AscW Debug.Print a Next i Loop rst.Close: Set rst = Nothing End Function ونناديه من نافذة الكود هكذا (يجب ان يكون الكيبور باللغة الانجليزة عند كتابة علامة الاستفهام) : . ونرى ان النتيجة للسجل الاول فقط : . وبعد التدقيق ، نلاحظ ان في نهاية الارقام نرى ان AscW التالية متكررة 8236 ثم 8236 ثم 32 ثم 32 ، وبذلك يمكننا استعمال هذه كشرط القطع بعد الاسم ا(1575) ق(1602) ل(1604) ح(1581) ا(1575) د(1583) م(1605) ح(1581) ي(1610) ا(1575) م(1605) و(1608) د(1583) د(1583) س(1587) ه(1607) ?(8236) ?(8236) ?(8236) -32 -32 -32 -32 -32 -32 . بعد الرقم 3(1635) 2(1634) ?(8236) ?(8236) ?(8236) ?(8236) -32 -32 -32 -32 . وعليه نستعمل هذا الكود ، ونرى نتيجته (للسجل الاول) : Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) Debug.Print x(i) Next i rst.MoveNext Loop ونتيجته ?ابراهيم احمد يحيى احمد? ??3 ?ابتهاج سامح نسيم اقلديوس? ??2 ?ابتسام محمد عبدا حماده? ??1?? . والآن خلينا نفكك الاسم من الرقم : Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) 'Debug.Print x(i) x2 = Split(x(i), ChrW(8236) & ChrW(32) & ChrW(32)) For j = LBound(x2) To UBound(x2) Debug.Print x2(j) Next j Next i rst.MoveNext Loop والنتيجة ?ابراهيم احمد يحيى احمد ??3 ?ابتهاج سامح نسيم اقلديوس ??2 ?ابتسام محمد عبدا حماده ??1?? . ونلاحظ من القائمة اعلاه ، ان علامات الاستفهام ارقامها ?(8235) ?(8234) ?(8236) . الخطوة الاخيرة هي تنظيف النتيجة من علامات الاستفهام هذه عن طريق الامر Replace ، والتخلص من المسافة الزائدة قبل وبعد النتيجة عن طريق الامر Trim ، وبعدها نريد ان نحفظ الاسم في اول حقل ، والرقم في الحقل الثاني: LBound دائما تساوي صفر Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) 'Debug.Print x(i) x2 = Split(x(i), ChrW(8236) & ChrW(32) & ChrW(32)) For j = LBound(x2) To UBound(x2) 'Debug.Print x2(j) a = Replace(x2(j), ChrW(8234), "") a = Replace(a, ChrW(8235), "") a = Replace(a, ChrW(8236), "") a = Trim(a) 'If j / 2 = Int(j / 2) Then If j = 0 Then 'even Debug.Print "Name: ", a Else 'odd Debug.Print "ID: " & a End If 'Debug.Print a Next j Next i rst.MoveNext Loop والنتيجة Name: ابراهيم احمد يحيى احمد ID: 3 Name: ابتهاج سامح نسيم اقلديوس ID: 2 Name: ابتسام محمد عبدا حماده ID: 1 Name: احمد السيد على محمد ID: 6 Name: ابراهيم كمال ابراهيم محمد ID: 5 Name: ابراهيم سمير عياد عطاا ID: 4 Name: احمد حسن احمد رسلن ID: 9 Name: احمد حجازى على محمد ID: 8 Name: احمد السيد محمد عبدالرحمن ID: 7 . -------------------------------------------------------- وفي سياق هذا الموضوع ، كان عندي مشروع القرآن الكريم ، وحفظه في قاعدة البيانات بعدة طرق: كل صفحة عبارة عن سجل ، وفي جدول آخر ، كل سطر في سجل ، وفي جدول آخر ، كل آية في سجل وقمت بتنزيل القرآن الكريم من مجمع الملك فهد لطباعة المصحف الشريف : https://fonts.qurancomplex.gov.sa/wp02/حفص والمرفق يحتوي على الخط العثماني ، والذي تم عمله في المجمع ، ولذا فهو يحتوي على حروف/ارقام/علامات AscW تختلف عن غيرها من الخطوط ، والطريقة الوحيدة لتفكيك الاسطر كانت بإتباع خطوات شبيهه بالخطوات اعلاه 🙂 جعفر

وعليكم السلام 🙂 الافضل ان تجعل الاستعلام مصدر بيانات للنموذج ، لأنك هناك تقدر تعمل تصفية ، و فرز (التسلسل) الذي تريده ، ويمكن عمل فرز لأاكثر من حقل ، مثلا: الفرز الاول يكون باسم القسم ، ثم الفرز التالي يكون للدرجة ، ثم الفرز التالي يكون للإسم ، وهكذا 🙂 جعفر

talal baghdadi أين الضغط على الإعــــجـــــاب لهذه الإجابة الممتاز لأستاذنا الكبير سليم ؟!!!💙

تم معالجة الامر 1- عندما تضغط على الزر Choose to delete تظهر لك رسالة تحتار منها رقم النظاق الذي تريد مسجة الأرقام مسجلة الى جانب كل نطاق 2- الزر Add Data Val ما زال يقوم بعمله ====>> ادراج القوائم المنسدلة (يستعمل في حال التعديل على مصدر البيانات لهذه القوائم) Option Explicit Sub Ad_Data_Val() With Range("Data_Val").Validation .Delete .Add 3, Formula1:="=Source_Rg" End With End Sub '++++++++++++++++++++++++++++++++++++++++ Sub del_special_range() Dim InpB InpB = Application.InputBox("Choose to Delete from 1 to 6:" & Chr(10) & _ "1- " & Range("Data_Val").Areas(1).Address(0, 0) & Chr(10) & _ "2- " & Range("Data_Val").Areas(2).Address(0, 0) & Chr(10) & _ "3- " & Range("Data_Val").Areas(3).Address(0, 0) & Chr(10) & _ "4- " & Range("Data_Val").Areas(4).Address(0, 0) & Chr(10) & _ "5- " & Range("Data_Val").Areas(5).Address(0, 0) & Chr(10) & _ "6- " & Range("Data_Val").Areas(6).Address(0, 0)) If Val(InpB) <= 0 Then MsgBox "You Must Choose Only Number from 1 to 6" Exit Sub End If If InpB <= 6 And InpB >= 1 Then InpB = Int(InpB) Range("Data_Val").Areas(InpB) = vbNullString Else MsgBox "You Must Choose Only Number from 1 to 6" End If End Sub الملف الجديد مرفق Talal_2.xlsm

ربما ينفع هذا الكود Option Explicit Sub del_Data_Val() Range("Data_Val").Validation.Delete '++++++++++Optional+++++++++++ Range("Data_Val").Value = "" End Sub '++++++++++++++++++++++++++++++++++++++ Sub Ad_Data_Val() With Range("Data_Val").Validation .Delete .Add 3, Formula1:="=Source_Rg" End With '++++++++++Optional+++++++++++ Range("Data_Val") = "" End Sub لك حرية ان تبقي على القيم الموجودة او لا بمسح ما يوجد داخل المربع الاحمر حسب هذه الصورة الملف مرفق Talal.xlsm

تم معالجة الأمر (مع الاشارة الى سبب الحطأ) Osama-1.xlsx

السلام عليكم 🙂 وهذه طريقة اخرى ، للنواتين 32 و 64بت : . او ايش رايك في كلمة سر متغيرة ، يعني مافي داعي تخاف احد يشوفها ، لأنها تتغير دائماً كل دقيقة 🙂 جعفر

السلام عليكم 🙂 رجاء مراجعة موضوع النسخة 2 من هنا : واجهة هذه النسخة: البرنامج يقوم بهذه الخطوات التي يوصي بها المحترفين (كما هو موضح في الصورة اعلاه) ، طريقة العمل: 1. اختار ملف اكسس ، 2. اذا الملف محمي بكلمة سر ، فيمكن كتابته في المربع المخصص ، حيث سيتم حفظه في ذاكرة الكمبيوتر ، والتي يجب عليك ان تدخلها يدويا للقيام بالخطوات 2 و 3 لمرة واحدة ، بينما البرنامج سيدخلها تلقائيا للخطوات التالية ، 3. يجب ان تمسك مفتاح الشفت ، ثم تضغط على زر Decompile ، ولا تترك الزر إلا لما ينتهي البرنامج من عمله ، عندما نرى الخطوات 8 و 9 🙂 هذه النسخة اسرع من النسخة السابقة ، وافضل 🙂 جعفر Decompile_3.zip

السلام عليكم ورحمة الله وبركاته 📜برنامج المخزون والفواتير الشامل الإصدار الرابع 2020 البرنامج هو تحديث للاصدارات السابقة من نفس البرنامج اولا وقبل كل شيئ اعتذر عن التأخير فى اطلاق هذا الاصدار نظرا لانشغالي الدائم وظروف خارجه عن الارادة. كما هو معروف عن برنامج المخزون و الفواتير الشامل: واجهة تطبيقية كاملة علي الاكسيل يصلح لكافة اغراض المبيعات و المشتريات وذمم عملاء وموردين و حساب المصروفات مع ميزانية عامه توضح الربح و الخساره. البرنامج مليئ بافكار جديده فى طريقة ادخال الاصناف داخل الفواتير و استدعائها و التعديل عليها.بالاضافه الي طرق جديده فى تصميم الفاتورة كما يتميز البرنامج بكثرة التقارير وسهولة الحصول عليها فى اى وقت يعمل علي جميع اصدارات الاكسيل بنواتين 32 أو 64 بت ويفضل دائما الاصدارات الاحدث من الاكسيل اوفيس 2019 و 365 البرنامج مجاني بنسبة 100 % للاستخدام الشخصي ولا يوجد به تاريخ انتهاء. وتستطيع استخدامه بامان تام.ويمنع بيع البرنامج او اي ربح تجاري بدون الرجوع الي المالك الاصلي.و الله الشاهد علي ذلك. تم تصميم البرنامج بمواصفات خاصه ويعمل للشركات الصغيره الي متوسطة الحجم او للمشاريع الخاصه .وهو فى الاصل برنامج تجارى ولكنى اقدمه هنا للمنتدى وللأخوة الاعضاء بصورة مجانية. تم اطلاق الاصدار الاول من هذا البرنامج عام 2012.وكل ما يلزم هو وجود نسخة اكسيل علي جهازك.وسيفي بالغرض تماما. هذا هو اخر اصدار للبرنامج علي اكسيل و الاصدار الخامس و لمزيد من التحسينات الكبيره سوف يتم تطويره إن شاء الله بلغة برمجه اخري وقاعده بيانات اخري. الدخول الاول:اسم المستخدم "مدير" و الباسورد 123 تم ارفاق نسختين من البرنامج نسخة الاستخدام المباشر كمستخدم ويمكنك استخدامها فى عملك مباشرة. نسخة اخري للتعلم مفتوحة المصدر وتوجد بها جميع الاكواد لجميع الشاشات داخل البرنامج للتعلم او التعديل عليها كما هو الغرض الرئيسي من هذا الصرح العظيم. يمكنك الرجوع الي الاصدارات السابقة حيث يوجد شرح كامل لكيفية استخدام البرنامج لاول مرة. توجد الروابط للاصدارات السابقة و الشرح اسفل هذا الموضوع . 📑الجديد في هذا الاصدار (2020)SIS Ver.4: شاشة تصميم الفواتير و هي من الشاشات الجديدة وبها الكثير من الاكواد الجديده فى الاكسيل (علي حسب علمي) حيث تمكنك من وضع اللوجو الخاص بالمؤسسه او الشركة الخاصه بك كما يمكنك ايضا وضع بياناتك اسفل الفاتورة كرقم التليقون و العنوان و ...... التحكم الكامل في بعض القيم و ظهورها داخل الفاتورة كرصيد العميل. شاشة اختيار عملة الدولة ووضع الضريبه او القيمه المضافه تمكنك هذه الشاشه من اختيار العمله علي حسب الدوله التي تعمل فيها. كما تمكنك من ضبط قيمة الضريبه او القيمه المضافه لفواتيرك شاشة ضبط صلاحيات المستخدمين بعد اضافة مستخدم جديد للبرنامج تستطيع ضبط صلاحيات المستخدم من الوصول الي جميع شاشات البرنامج شاشة حذف البيانات الغير مستخدمة بكل سهولة تستطيع حذف العملاء و الموردين او الاصناف الغير مستخدمة داخل البرنامج. شاشة الحركة المالية السريعة تستطيع ادخال سند صرف موردين او سند عميل بضغطة زر واحده. شاشة الفواتير الكثير من التحسينات تم ادارجها داخل شاشة الفواتير فاتورة المشتريات . انت من يقوم بوضع رقم الفاتورة الخاصه من المورد.بدلا من وضعها اتوماتيكيا كالاصدار السابق. اضافة خصم اجمالي علي الفاتورة. يتم تحديد الخصم كنسبه مئويه او خصم مبلغ مقطوع. اضافة الضريبه علي الفاتورة ويمكن تحديد قيمتها يدويا او تثبيتها من خلال شاشة البيانات الجديده وضبط الضريبه او القيمه المضافه علي حسب الدولة. مبيعات نقدي: فى حالة اختيار هذا النوع من الفواتير يتم ادراج سند قبض مباشره الي حساب العميل مع حفظ الفاتورة لانها مبيعات نقدية. ظهور رصيد العميل الحالي داخل الفاتورة. و التحكم في ظهوره من خلال شاشة تصميم الفاتورة. زر لسداد كامل الفاتورة مباشرة وادراج سند قبض او سند صرف داخل حساب العميل/المورد سند بالمبلغ المدفوع داخل الفاتورة وتسوية حساب العميل او المورد. شاشة الحركات المالية ادراج الكثير من الحركات المالية داخل سند الصرف. شاشة جديده لحساب رواتب وجميع الحسابات للموظفين العاملين فى المؤسسة او الشركة يوجد الكثير من الاضافات و التحسينات علي كل الشاشات والتقارير داخل البرنامج . تستطيع اكتشاف المزيد و المزيد اثناء استخدام البرنامج. التعامل مع رصيد اول المده (كميات الاصناف- حسابات العملاء/الموردين) تم الاستغناء عن شاشة اكواد البيانات والجرد فى هذا الاصدار وكانت تستخدم لوضع رصيد اول المده للاصناف. وعوضا عن ذلك ولحساب المخزون بطريقه منظمه يجب ان يتم وضع كميات اول المده لجميع الاصناف من خلال فاتورة مشتريات باسعار شراء محدده حتي يتم ادراجها وحسابها بطريقه دقيقه.وايضا فى حالة رصيد سابق للعملاء والموردين يجب ان يتم ادخاله من خلال شاشة الحركات الماليه( حركة ماليه رصيد اول مده او ترحيل لحساب عميل/مورد) طباعة الباركود لا تزال غير مفعله ايضا فى هذا الاصدار. 👁️‍🗨️شرح كيفية استخدام البرنامج وادخال البيانات من الاصدارت السابقة:(برجاء مراجعة الروابط التالية) شرح برنامج المخزون و الفواتير الشامل(مشاركة داخل المنتدى) استخدام البرنامج لاول مره من الاصدار الثالث شرح برنامج المخزون و الفواتير الشامل( ملف تنفيذى... 6MB رابط خارجى على موقع ميديا فاير) 🏷️تحميل البرنامج: النسخة الاولي SIS 4.566EO : هى نسخة المستخدم النهائي مجانيه 100 % لاعضاء المنتدي الكرام وليس لها تاريخ انتهاء وكما ذكر سابقا هي للاستخدام الشخصي فقط. 💳SIS 4.566EO.rar النسخة الثانيه SIS 4 Learning : هي نسخة للمطورين و الباحثين عن التعلم وهي نسخة مفتوحة المصدر تحتوي علي جميع اكواد الشاشات داخل البرنامج. 🧼SIS4(Learning).rar إن شاء الله سوف اقوم بالرد علي استفسارات اعضائنا الكرام عندما يتوفر لي الوقت و اعتذر مقدما عن اي تاخير نظرا لانشغالي الدائم. اخيرا أحب انا أشكر جميع مشرفي و اعضاء هذا الصرح العظيم. واتمني من الله ان يكون هذا العمل خالصا لوجه الله سبحانه و تعالي و انا اكون قد قدمت تجربه جيده لهذا النوع من البرامج علي الاكسيل وان ينفع به جميع اعضاء المنتدي الكرام

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

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

السلام عليكم مشاركه مع اخى واستاذى الدكتور حسين @د.كاف يار اتفضل اخى @husseinharby تعديل بسيط على كود اخى واستاذى حسين جرب ووافنا بالنتيجه Private Sub item_AfterUpdate() [sale_qty] = 1 If Len(number & "") = 0 Then number = Nz(DMax("[number]", "[details]", "[sale_id]=[Forms]![sale]![sale_id]"), 0) + 1 Else End If End Sub بالتوفيق copy(2).accdb

هذا حل بالمعادلات عد البنود المحددة slicer.xlsx

اعتقد هذا المطلوب Private Sub Worksheet_PivotTableChangeSync(ByVal Target As PivotTable) Range("h2") = ActiveWorkbook.SlicerCaches(1).VisibleSlicerItems.Count End Sub count selected item in slicer .xlsm

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

جزاك الله خيرا اخي الكريم وارجو من الله العلي القدير ان يصلح لنا الاحوال وان يوفقك لما يحب ويرضى واكرر شكري وتقديري لك اخهي الكريم تحياتي

شرح البحث في الاكسل باستخدام دالة Index + mach للشرح شاهد الفديو شرح البحث في الاكسل لتحميل ملف العمل من هنــــا برجاء تغيير اسم الظهور الى اسم عربى له معنى بدلاً من abdo2015egy@gmail.com

mostafa_star1988 اشكرك ولكن للاسف الشديد وعليه اقوم مرة اخرى بارفاق الملف الاصلي املا من لديه خبرة بالاكسل المساعدة برنامج.xlsm

السلام عليكم ورحمة الله و بركاته ارجو ان يكون هذا الحل المطلوب برنامج.xlsm

اجعل المعادلة هكذا حتى تستطيع قراءة شهر 8 مثلاً =SUMPRODUCT((Sheet1!C2:C45<>"الغاء")*(Sheet1!F2:F45<>"محصل")*(Sheet1!D2:D45="معارض - Bmw")*(Sheet1!E2:E45)*(Sheet1!G2:G45=MONTH(S1))) Sum_pro1.xlsx

السلام عليكم ورحمة الله جرب هذا الكود Sub Add_Data() Dim ws As Worksheet, Arc As Worksheet Dim LR As Long Set ws = Sheets("hassila") Set Arc = Sheets("Archives") LR = Arc.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Copy Arc.Activate Arc.Range("A" & LR + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False ' :اذا اردت مسح البيانات من الورقة الاولى قم بازالة العلامة التى على اليسار من العبارة التالية 'ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row-1).ClearContents End Sub

السلام عليكم أخي يمكنك مشاهدة هذا الدرس

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

السلام عليكم جرب هكذا موضح على الكود السطور الاختياريه الكود في مودويل Public Msg_a As String Public Function B_A(Str_B As String) As Boolean Dim Work As Workbook On Error Resume Next Set Work = Workbooks(Str_B) On Error GoTo 0 If Work Is Nothing Then B_A = False Else B_A = True End If End Function Public Sub Target_Ali() With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim خلية_الرقم As Range, خلية_المسار As Range Set خلية_الرقم = Range("N1") ' هذا يعبر عن خلية إدخال الرقم غيرها الى اي خليه تريدها Set خلية_المسار = Range("M1") ' هذا يعبر عن خلية مسار الملف غيرها الى اي خليه تريدها If Not خلية_الرقم Is Nothing Then Dim Str_B As String Dim T_A, C, A Str_B = "main.xls" If B_A(Str_B) Then If خلية_الرقم.Text = "" Then MsgBox " خلية الرقم فارغة :" & خلية_الرقم.Address, vbExclamation, "تنبية !!!": Exit Sub If خلية_الرقم.Value = 1 Then '*************************** If Ali_TQrar(خلية_المسار) = True Then ' A = GetSetting("Ali_A", "Ali_B", "Ali_C", (Msg_a)) ' MsgBox " هذه القيمة :" & " " & خلية_المسار.Text & vbNewLine & vbCrLf & " موجوده في ملف :" _ & Str_B & " " & vbNewLine & vbCrLf & " في الخلايا التالية :" & " " & A, vbInformation, "تنبية !!!" ' DeleteSetting "Ali_A", "Ali_B" ' Exit Sub End If '*************************** Dim s As Worksheet With Workbooks(Str_B) ' هذا التعبير عن ملف Main W_Name = ThisWorkbook.Name T_A = خلية_المسار.Text Set s = .Sheets(1) ' هنا رقم الورقة المراد لصق البيانات فيها في ملف Main L_A = s.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Row ' هنا اخذ اخر صف به بيانات + صف من عمود C للصق القيم المنسوخه s.Cells(L_A, "C") = T_A ' تسجيل قيمة خلية المسار عمود C بإمكانك تغيره لأي عمود s.Cells(L_A, "B") = W_Name ' تسجيل إسم ملف المنسوخ منه في عمود B .Save End With ElseIf خلية_الرقم.Value = 0 Then Call Ali_D End If Else MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation Exit Sub End If End If .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Sub Private Sub Ali_D() With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim Ar() As Variant Dim Wo As Workbook, T_W As Workbook Dim Sh As Worksheet Dim Str_B As String Dim R As Range Dim i, ii, C, M_r, Rw Str_B = "main.xls" Set Wo = Workbooks(Str_B) Set T_W = ThisWorkbook Wo.Activate Set Sh = Wo.Sheets(1) Set R = Sh.Range("C2:C1000") With R For i = 1 To .Rows.Count If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = T_W.Sheets(1).[C1] Then ReDim Preserve Ar(0 To C) Ar(C) = .Cells(i, 1).Address C = C + 1 End If Next If Len(C) > 0 Then For ii = LBound(Ar) To UBound(Ar) Rw = Rw + 1 M_r = M_r & "," & Ar(ii) Next Wo.Sheets(1).Range(Mid(M_r, 2, Len(M_r))).EntireRow.Delete Shift:=xlUp MsgBox "تم حذف القيمة المطابقة من ملف : " & Wo.Name & " " & " عدد الصفوف التي تم حذفها :" & Rw, vbExclamation, "تنبية !!!" Else MsgBox "لاتوجد قيمة مماثله في : " & Wo.Name, vbExclamation, "تنبية !!!" End If End With Erase Ar Wo.Save T_W.Activate .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Sub Public Function Ali_TQrar(خلية_المسار_A As Range) As Boolean With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim Max_r() As Variant Dim Wo As Workbook, T_W As Workbook Dim Sh As Worksheet Dim Msar_B As String, Msg_a As String Dim Va_Text As String Dim R As Range, Rc As Range Dim i, ii, Val_Ar, M_r, Rw Msar_B = "main.xls" Set Wo = Workbooks(Msar_B) Set T_W = ThisWorkbook Wo.Activate Set Sh = Wo.Sheets(1) 'رقم الورقة في ملف Main Set R = Sh.Range("C2:C1000") ' المدى المراد التحقق منه بياناته تحسبا للتكرار Set Rc = خلية_المسار_A Va_Text = Rc.Text ' خلية المسار في الملف التسلسلي With R For i = 1 To .Rows.Count If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = Va_Text Then ReDim Preserve Max_r(0 To Val_Ar) Max_r(Val_Ar) = .Cells(i, 1).Address Msg_a = Msg_a & vbCrLf & .Cells(i, 1).Address & vbCrLf Debug.Print Msg_a Val_Ar = Val_Ar + 1 End If Next '*********************************************** SaveSetting "Ali_A", "Ali_B", "Ali_C", (Msg_a) '*********************************************** If Len(Val_Ar) > 0 Then Ali_TQrar = True End With Erase Max_r T_W.Activate .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Function