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

السلام عليكم ورحمة الله وبركاته أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل . فكرة الكود : عند فتح الملف يتم انشاء ملف نصى دون شعور المستخدم يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى : 1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه 2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل الكود وعليه الشرح : Option Explicit Private Sub Workbook_Open() Dim StartTime#, CurrentTime# '---------------------------------------------------------- ' اعداد الفترة التجريبية كالتالى ' Integers 1, 2, 3,30 ,365 ...etc = number of days use ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use Const TrialPeriod# = 30 ' 30 days trial '---------------------------------------------------------- 'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية Const ObscurePath = "C:\" Const ObscureFile = "Test File Log.Log" 'اذا كان الملف ذو المسار والاسم المحدد فارغا فان If Dir(ObscurePath & ObscureFile) = Empty Then ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص StartTime = Format(Now, "#0.#########0") 'جواب الشرط : افتح الملف ذو المسار والاسم المحدد Open ObscurePath & ObscureFile For Output As #1 'تابع جواب الشرط : اكتب فى الملف بداية الوقت Print #1, StartTime Else ' فى حالة عدم تحقق الشرط فان 'افتح الملف ذو المسار والاسم للتحقق من وقت البداية Open ObscurePath & ObscureFile For Input As #1 Input #1, StartTime ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص CurrentTime = Format(Now, "#0.#########0") 'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية If CurrentTime < StartTime + TrialPeriod Then Close #1 ' غلق الملف المبهم قيد الاستعمال Exit Sub ' الخروج من الاجراء Else ' فى حالة عدم تحقق الشرط If [A1] <> "Expired" Then ' اذا كانت الخلية لا تساوى النص "Expired" فان ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف للاستعمال MsgBox "Sorry, your trial period has expired " & vbLf & _ "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _ "This workbook will then be made unusable." Close #1 ' غلق الملف المبهم قيد الاستعمال SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم [A1] = "Expired" ActiveWorkbook.Save ' حفظ الملف Application.Quit ' اغلاق اكسل نهائيا ElseIf [A1] = "Expired" Then ' اذا كانت الخلية تساوى النص "Expired" فان Close #1 ' غلق الملف المبهم قيد الاستعمال Application.Quit ' اغلاق اكسل نهائيا End If End If End If Close #1 End Sub Sub SaveShtsAsBook() ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False ' ايقاف تحديث الشاشة .DisplayAlerts = False ' ايقاف التنبيهات On Error Resume Next ' فى حالة الخطأ تجاهله MkDir MyFilePath ' انشاء مجلد فارغ باسم الملف For N = 1 To Sheets.Count ' حلقة تكرارية بعدد أوراق الملف Sheets(N).Activate ' تنشيط الشيت SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت Cells.Copy ' نسخ كامل الشيت Workbooks.Add (xlWBATWorksheet) ' انشاء ملف اكسل جديد With ActiveWorkbook ' مع الملف النشط With .ActiveSheet ' مع الشيت النشط .Paste ' لصق البيانات فيه .Name = SheetName ' تسمية الشيت النشط [A1].Select ' تنشيط الخلية End With ' حفظ الملف النشط فى المجلد باسم الشيت النشط .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls" ' غلق الملف النشط مع حفظ البيانات .Close SaveChanges:=True End With .CutCopyMode = False ' تفريغ الذاكرة العشوائية Next ' الشيت التالى End With ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد Open MyFilePath & "\Read Me.log" For Output As #1 ' كتابة الأسطر التالية فى الملف النصى Print #1, "Thank you for trying out this product." Print #1, "If it meets your Requirements, visit :" Print #1, "http://www.officena.com " Print #1, "to purchase the full version..." Print #1, "" Print #1, " --------- Regards -------------" Print #1, "Mokhtar Hussien officena team" Close #1 ' غلق الملف النصى End Sub الكود يوضع فى حدث Workbook بامكانك تعديل مسار الملف النصى وبامكانك تعديل الفترة التجريبية الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود لتجربة الكود : اذهب الى الملف النصى ستجد رقما زى كده : 42298.7085185185 ده هو وقت تشغيل الملف نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح 42298. يعنى نخلية 42250 مثلا ونحفظ الملف النصى على كدة روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش مرفق للتجربة : Trial Version Ended 30 days.rar

أخى محمد انظر الرابط http://www.officena.net/ib/topic/64284-من-يريد-حماية-متميزة-لبرنامجه-يتفضل/ لأخينا ياسر العربى وده كود منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد ' Private Sub Workbook_Open() ' Dim MyPath As String ' Dim MyFlName As String ' ' MyPath = "Z:\SHARED GENERAL" ' MyFlName = "TEST-1.xls" ' If ThisWorkbook.Path <> MyPath Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' If ThisWorkbook.Name <> MyFlName Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' End Sub ' Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) ' Dim lReply As Long ' ' If SaveAsUI = True Then ' lReply = MsgBox("عفواً لايمكنك حفظ هذا الملف بإسم جديد .. هل تريد حفظ الملف بإسمه الحالي ؟", vbQuestion + vbOKCancel) ' Cancel = (lReply = vbCancel) ' If Cancel = False Then Me.Save ' Cancel = True ' End If ' End Sub عدل فى الكود اسم و مسار الملف كما تشاء فاذا كان اسم الملف ومسار الملف غير المثبت فى الكود لن يفتح الملف

أخي الكريم 66 محمود (قال يعني إحنا قادرين على محمود واحد ..لما نقابل 66 محمود مرة واحدة) سأقوم بتناول حلول مختلفة واختر منها ما يناسبك .. قمت بإنشاء مصنفين واحد باسم Test والثاني باسم Sample .. في المصنف الثاني قمت بوضع قيمة في الخلية A1 ، وفتحت المصنف الأول ووضعت معادلة في الخلية G7 كما بالصورة إذا نظرت لشريط المعادلات ستجد علامة يساوي يليها علامتين تنصيص مفردة بهذا الشكل ' ... وما بين العلامتين يوجد مسار المصنف المسمى Sample بالكامل ثم \ ثم اسم المصنف ما بين أقواس [ ] ثم يليه مباشرةً ورقة العمل الأولى في المصنف المصدر ...وأخيراً بعد علامة التنصيص المفرة الثانية ' يوجد علامة تعجب ! ثم الخلية المصدر A1 الحل الذي قدمه أخونا الحبيب مختار حسين ..الخطوات كما بالصورة الحل المقدم صحيح 100% ولكن لكي تكتمل الخطوات لابد من تغيير في إعدادات الإكسيل ، من خلال خيارات الإكسيل Excel Options ثم انقر على Trust Center ثم Trust Center Settings ثم اختر من القائمة في الجهة اليسرى External Content واختر الخيار الأول في القسمين الظاهرين في النافذة لديك احفظ وأغلق المصنف و قم بتجربة المصنف المسمى Sample بأن تضع أي قيمة جديدة في الخلية A1 واحفظ المصنف وأغلقة ، ثم قم بفتح المصنف Test ستجد أن البيانات يتم تحديثها ************************ حل آخر بعيداً عن تغيير الإعدادات بكود يوضع في حدث المصنف Test بهذا الشكل ، ويقوم بتحديث الروابط للملفات الخارجية Update All External Links Private Sub Workbook_Open() 'UpdateLinks All Links '--------------------- Dim MyLink As Variant For Each MyLink In ActiveWorkbook.LinkSources(xlExcelLinks) ActiveWorkbook.UpdateLink Name:=MyLink, Type:=xlExcelLinks Next MyLink End Sub لتجربة الكود والتأكد من عمله قم بإرجاع الإعدادات في الصورة الأخيرة إلى الخيار الثاني في القسمين prompt user about Data Connections Prompt user on automatic update for workbook links احفظ المصنف المسمى Test بعد وضع الكود في حدث المصنف ... اذهب للمصنف المسمى Sample وعدل الخلية A1 واحفظ وأغلق افتح المصنف Test لتجد أنه تم تحديث البيانات بدون تغيير في الإعدادات ..فقط بكود يوضع في حدث المصنف أرجو أن أكون قد وفقت في توصيل المعلومة بشكل بسيط يسهل فهمه الرجاء تغيير اسم الظهور للغة العربية والإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل بشكل أفضل مع المنتدى تقبل تحياتي

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

تم بحمد الله وفضله ثنائيه رائعه من العمل والعلم اخي ياسر واخي مختار زادكم الله من علمه وفضله

مبروك .. أنت لها .. الله يعينك

السلام عليكم جميعا ورحمته الله وبركاته أخى الفاضل الاستاذ // رضا راغب أهلا وسهلا بك أخى الكريم بين إخوانك المتميزين خلقا وعلما وأدبا وبعد إذن اخى الحبيب // ياسر خليل " أبو البراء " وإثراءا للموضوع إليك هذا الكود وبإذن الله تعالى ستجد حلا للموضوع جزاكم الله خيرا وبارك فيكم Private Const cRunWhat = "Tarhil_Values" Private RunWhen As Double, Arr() As Range, CurIndex As Long Public Sub StartTimer() Dim A As Areas, I As Long If RunWhen > 0 Then MsgBox "The Process Is Already Running" Exit Sub End If Set A = Sheets("Sheet1").Columns("A").SpecialCells(2, 1).Areas ReDim Arr(1 To A.Count) For I = 1 To A.Count Set Arr(I) = A(I).CurrentRegion Next I CurIndex = 0 RunWhen = Now + TimeSerial(0, 0, 10) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=True End Sub Public Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=False RunWhen = -1 MsgBox "Transferring Data Will Be Turned Off" End Sub Private Sub Tarhil_Values() CurIndex = CurIndex + 1 If CurIndex > UBound(Arr) Then StopTimer Exit Sub End If Arr(CurIndex).Copy Sheets("Sheet2").Cells(Arr(CurIndex).Row, "C") Application.CutCopyMode = False RunWhen = Now + TimeSerial(0, 0, 10) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, Schedule:=True End Sub

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

الكود يعمل بطريقة ممتازة انتبه الا تضع اي مسافة فارغة قبل الاسم انظر المرفق talween 1.zip

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

جرب المرفق التالي Prog1000.rar

تفضل ,ولى الامر .rar

أخى العزيز ياسر موضوع استخدام Integer أو Long بيكون حسب البيانات المطلوبة كما بالجدول التالى .. ويفضل لو كان حاجة خفيفة تستعمل الأخف وهو Integer الكلام ده مش بيفرق كتير هنا لكن لو ها تبنى قاعدة بيانات كبيرة بالاكسس او احدى برامج البيانات الاخرى بيقرق كتير لأنه بيحجز مساحة لكل حقل بيانات حسب المتغير المطلوب منه يعنى مثلا لو قاعدة بيانات بها من النوع Integer هاتكون المساحة/ الحجم المطلوب لقاعدة البيانات نصف المطلوب للمتغير Long عن كل سطر من البيانات VB Alias Size Range Integer 32 bits (4 bytes) -2,147,483,648 to 2,147,483,647 Long 64 bits (8 bytes) -9,223,372,036,854,775,808 to 9,223,372,036,854,775,807

السلام عليكم موضوع ربط الاكسل بالفيجيوال موضوع جميل. بس انا ليا وجهة نظر من خلال خبرتى فى التعامل مع الموضوع ده وهو ان الإكسل ليس هو الحل الامثل للتعامل مع الفيجيوال كقاعدة بيانات فهناك العديد من قواعد البيانات اسهل منه فى التعامل واقربها الى منتدياتنا هنا هو الأكسيس ويمكن الاستعانة فى تلك المرحلة بالاكسل كمستعرض جيد للتقارير وده كنت عملته قبل كده فى برنامج خاص قاعدة بياناته أكسس وتقاريره على الإكسل والورد بصراحة التعامل مع الفيجوال وبخاصة فى المواضيع اللى بتتعامل مع بيانات كتيره وكذلك تعدد المستخدمين فى نفس الوقت اريح بكتير. وانا بتراودنى نفس الفكرة اللى طرحها الأستاذ العزيز ياسر ابوالبراء ولكنها فكرة قسم جديد هنا فى المنتدى للفيجوال دوت نت (مستقل عن الاكسل) وحاليا مايكروسوفت منزلة الاصدار 2015 مجانى لكن القسم ده طبعا محتاج متخصصين ومحترفين لمساعدتنا فيه الا إذا بدأنا كلنا مع بعض نتعلم ونزود بعض .... على فكره كل اللى عنده فكرة عن الفورم والبرمجة فى الاكسل ممكن يبدأ بسهولة لانها نفس الفكرة لكن الجديد هو عندما نتعامل مع البيانات هنحتاج شوية أكسس وشوية SQL , وكمان لما ها يبقى القسم مستقل هايكمل بزيارات خبراء من قسم الاكسس يساعدونا ونتعلم كلنا لو موافقين على القسم ده خلونا نرفع للادرة رغبتنا فى فتحه ونبدأ مع بعض نتعلم ونتعاون فى تنمية مهاراتنا مع بعض واظن انه هيكون مفيد للجميع.

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

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

ألف مليون مبروك أخى الحبيب / خالد الرشيدى على الترقية المستحقة مع مزيد من التقدم والرقى

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

جازاكم الله خيرا أخى وأستاذى الفاضل ياسر تقبل الله منا ومنكم صالح الاعمال بارك الله فيك أخى وائل ونفع بك تحياتى

لم ألتفت الى المعادلات أشكرك أخى ياسر على دقة المتابعة تم تعديل نوع لصق المنسوخ فى الكود Option Explicit Sub SaveShtsAsBook() Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1")) sh.Activate SheetName1 = ActiveSheet.Name SheetName2 = ActiveSheet.Name & "" & [c1] Cells.Copy Set NB = Workbooks.Add(xlWBATWorksheet) With NB With .ActiveSheet .Cells.PasteSpecial Paste:=xlPasteValues .Name = SheetName1 [a1].Activate End With ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False .Close SaveChanges:=True End With .CutCopyMode = False Set NB = Nothing Next sh Sheets("SAles").Activate .ScreenUpdating = True .DisplayAlerts = True End With End Sub

ادخلت بحدود 90000 موظف وما شاء الله سريع الحمد لله

لا استطيع الا ان اقول لله درك وزادك من علمة مميز كعادتك. تم حل المشكلة.

بارك الله فيك اخى الكريم (ياسر خليل أبو البراء ) وجعله فى ميزان حسناتك

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

أضف سطر الإعلان عن المتغيرات في أول الموديول Dim LR As Long, LRQ As Long, Cell As Range وإن شاء الله يتم حل المشكلة تقبل تحياتي

ههههههههههههههههى لو كنت أفضل واحدة لطبقتها كلها فيها ثغرات للدخول الى الملف

السلام عليكم اقول : جزيت خيرا - جزيت خيرا - جزيت خير اقول : رزقك الله حظ الدنيا والاخرة اقول : تمام تمام تمام 100 % انتهى البطأ اشكرك

أخي الكريم محمد اضغط من لوحة المفاتيح Alt + F11 هتدخل على محرر الأكواد من قائمة Insert هتلاقي الأمر Module انسخ الكود والصقه في الموديول احفظ الملف .. لما تظهر لك رسالة الحفظ بتكتب اسم الملف وتحدد مكانه وأهم شيء تخلي الامتداد Macro Enabled (نوع الحفظ من نفس النافذة) وأي استفسار ستجدنا بعون الله وتوفيقه تقبل تحياتي

حبيب قلبى وأخى فى الله الاستاذ القدير // ياسر خليل " ابو البراء " السلام عليكم ورحمته الله وبركاته تسلم من كل شر وياريت متحرمناش من مساهماتك التى أخبرتك بها سالفا دون رد اعانكم الله تعالى ورزقنا واياكم من حيث لانحتسب جزاكم الله خيرا وبارك فى البراء

وعليكم السلام أستاذ وائل استبدل السطر التالى فى كود المرفق ThisWorkbook.Sheets(Array("SAles", "Stk")).Copy Before:=NB.Sheets(1) بالسطر التالى : ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) تحياتى

أخي الكريم جرب الملف المرفق التالي ** الكود مقسم إلى كود يوضع في موديول عادي Public Arr, ArrOut Sub RefreshArray() Dim WS As Worksheet, ArrTemp, I As Long, P As Long ReDim Arr(1, 0) For Each WS In Sheets If WS.Name <> "البحث" And WS.Name <> "تصفية البيانات المكررة " And WS.Name <> "بيانات ثانوية" Then If WS.Cells(Rows.Count, "G").End(xlUp).Row > 1 Then ArrTemp = WS.Range("A1").CurrentRegion.Columns("G").Value I = UBound(Arr, 2) + UBound(ArrTemp, 1) ReDim Preserve Arr(1, I) For I = 2 To UBound(ArrTemp, 1) If Len(ArrTemp(I, 1)) Then Arr(0, P) = ArrTemp(I, 1) Arr(1, P) = WS.Name & "/" & I P = P + 1 End If Next I End If End If Next WS ReDim Preserve Arr(1, P - 1) End Sub Sub GetSearchResult(Param As String) Dim LastRow As Long, I As Long, P As Long If Not IsArray(Arr) Then RefreshArray ReDim ArrOut(1, UBound(Arr, 2)) With Sheets("البحث") LastRow = Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3) .Range("E3:E" & LastRow).ClearContents P = 0 For I = LBound(Arr, 2) To UBound(Arr, 2) If InStr(1, Arr(0, I), Param, vbTextCompare) Then ArrOut(0, P) = Arr(0, I) ArrOut(1, P) = Arr(1, I) P = P + 1 End If Next I If P > 0 And Param <> "" Then ReDim Preserve ArrOut(1, P - 1) .Range("E3").Resize(UBound(ArrOut, 2) + 1, 1).Value = Application.Transpose(ArrOut) Else .Range("B2:B26,D2:D26").ClearContents End If End With End Sub Sub RefreshList(Param As Long) Dim Arr, ArrOut1(1 To 25, 1 To 1), ArrOut2(1 To 25, 1 To 1), I As Long With Sheets("البحث") .Range("B2:B26,D2:D26").ClearContents On Error Resume Next Arr = Sheets(Split(ArrOut(1, Param - 3), "/")(0)).Rows(Val(Split(ArrOut(1, Param - 3), "/")(1))).Resize(, 56).Value If Err.Number <> 0 Then Exit Sub On Error GoTo 0 ArrOut1(1, 1) = Arr(1, 9) For I = 2 To 25 ArrOut1(I, 1) = Arr(1, I + 5) Next I For I = 1 To 25 ArrOut2(I, 1) = Arr(1, I + 31) Next I .Range("B2").Resize(UBound(ArrOut1, 1), UBound(ArrOut1, 2)).Value = ArrOut1 .Range("D2").Resize(UBound(ArrOut2, 1), UBound(ArrOut2, 2)).Value = ArrOut2 End With End Sub والجزء الثاني يوضع في حدث ورقة العمل المسماة "البحث" Private Sub TextBox1_Change() GetSearchResult TextBox1.Text End Sub Private Sub Worksheet_Activate() RefreshArray End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Columns("E")) Is Nothing Then If Target.Row >= 3 And Target.Count = 1 Then If Len(Target.Value) Then RefreshList Target.Row End If End If End Sub أرجو أن يكون المطلوب ويعالج مشكلة البطء لديك إن شاء الله تقبل تحياتي Textbox Search All Sheets YasserKhalil.rar

جرب هذا الملف talween.zip

شكراَ استاذ مختار

السلام عليكم أخى الأسيوطى جرب الملف التالى فيه نحفظ الورقة الاولى والثانية + ورقة من الاوراق التالية لهما فى ملف مستقل باسم حسب الخلية C1 فى هذه الورقه يتم تجميع الملفات الناتجة داخل مجلد يتم انشاؤه حسب اسم الملف والتاريخ الموجود في الخليه A1 من الصفحه الاولي لا تنسونا من صالح الدعاء ولو بظهر الغيب تحياتى Save Sheets As Books by mokhtar.rar

جرب الكود في موديول عادي واربطه بزر أمر سيعمل معك إن شاء الله Sub FilterSpecific() Application.ScreenUpdating = False With Sheets("Quires").Range("B15:G1000") .Offset(1).ClearContents .Borders.LineStyle = xlNone End With With Sheets("SQ") .Rows(1).AutoFilter .Rows(1).AutoFilter 11, "=" & Sheets("Quires").Range("H9") LR = .Range("A" & .Rows.Count).End(xlUp).Row If LR > 1 Then Union(.Range("D2:E" & LR), .Range("G2:G" & LR), .Range("J2:J" & LR), .Range("L2:L" & LR)).Copy Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues End If .Rows(1).AutoFilter End With With Sheets("Quires") LRQ = .Range("C" & .Rows.Count).End(xlUp).Row If LRQ > 15 Then For Each Cell In .Range("B16:B" & LRQ) Cell = Cell.Row - 15 Next Cell End If With .Range("B15").CurrentRegion .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With .Range("H9").Select End With Application.ScreenUpdating = True End Sub لا أدر ما السبب في عدم عمل الكود في حدث الورقة لديك .. قد تكون هناك مشكلة في مكان ما أو لربما لأن خلية الشرط مدمجة ...كل الاحتمالات واردة

أخي الكريم سعد يرجى تغيير اسم الظهور بشكل مناسب ليظهر اللقب مع الاسم إليك الكود التالي يوضع في حدث ورقة العمل المسماة Quires ..بمجرد الاختيار من الخلية H9 Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long, LRQ As Long, Cell As Range If Target.Cells.CountLarge > 1 Then Exit Sub If Not Intersect(Target, Range("H9")) Is Nothing Then Application.ScreenUpdating = False With Sheets("Quires").Range("B15:G1000") .Offset(1).ClearContents .Borders.LineStyle = xlNone End With With Sheet1 .Rows(1).AutoFilter .Rows(1).AutoFilter 10, "=" & Sheets("Quires").Range("H9") LR = .Range("A" & .Rows.Count).End(xlUp).Row If LR > 1 Then Union(.Range("D2:F" & LR), .Range("I2:I" & LR), .Range("K2:K" & LR)).Copy Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues End If .Rows(1).AutoFilter End With With Sheets("Quires") LRQ = .Range("C" & .Rows.Count).End(xlUp).Row If LRQ > 15 Then For Each Cell In .Range("B16:B" & LRQ) Cell = Cell.Row - 15 Next Cell End If With .Range("B15").CurrentRegion .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With .Range("H9").Select End With Application.ScreenUpdating = True End If End Sub وإليك الملف المرفق تقبل تحياتي Filter Copy Specific Data YasserKhalil.rar

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

السلام عليكم بعد إذن أساتذتنا الافاضل، ولإثراء الموضوع من منظور مختلف ياريت لو تجرب الكود ده .... والفرق بينه ومبين ما سبق انه بمجرد ما تعمل له تشغيل يقرا العدد المطوب من الخلية المجاورة ثم يقوم بادراج عدد التكرارات المطلوب دون التأثير على ما اسفله من بيانات تكرار بناء على عدد OB.rar Sub RepeatCellValue() Dim I As Integer Dim A A = ActiveCell.Offset(0, 1).Value If IsNumeric(A) Then For I = 1 To A ActiveCell.Copy Selection.Insert Shift:=xlDown Next Application.CutCopyMode = False End If End Sub تكرار بناء على عدد OB.rar

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

أخي الكريم رضا جرب الكود التالي عله يفي بالغرض Sub TarhilRanges() Dim R As Range For Each R In Sheet1.Columns("A").SpecialCells(2, 1).Areas Application.Wait (Now + TimeValue("00:00:05")) R.CurrentRegion.Copy Sheets("Sheet2").Cells(R.Row, "C") Next R Application.CutCopyMode = False MsgBox "Done!", 64 End Sub

أما إذا أردت ماكرو لرقم تباعد محدد، فإليك هذا الماكرو الذي يفترض أنك تريد تباعدا تاما من 24 نقطة (يمكنك تغيير الرقم كما تشاء) Sub LS() With Selection.ParagraphFormat .LineSpacingRule = wdLineSpaceExactly .LineSpacing = 24 End With End Sub

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

اخي ياسر اثراء للموضوغ اليك هذا الكود تستطيع ان تحدد اكثر من صف و اكثر من عامود للنكرار Sub repet() Dim myrg As Range Dim t As Integer Set myrg = Application.InputBox("Enter your data", Type:=8) t = Application.InputBox("Enter your number", Type:=1) myrg.Copy ActiveCell.Resize(t * myrg.Rows.Count, myrg.Columns.Count) End Sub

الاخ الفاضل جرب التالى من قائمة data اختر edit link وتأكد من أن الخيار automatic نشط ومن الصندوق الحوارى اضغط startup prompt من الصندوق الجديد حدد الخيار 3 ثم ok ثم close احفظ الملف واقفله ثم أعد الفتح وشوف

الطريقه الٍسابعه :- تعبئه الكمبوبوكس بدون تكرار باستخدام الحلقه التكراريه For Each و الداله Countif (طريقه احترافيه) لو عندى شيت زى كدا وفيه بيانات وعايز اقوم بتعبئة الكمبوبوكس بالبيانات المظلله باللون الاخضر ولكن دون تكرارشاهد الصوره هنستخدم نفس الكود السابق ولكن مع اضافه الداله Countif الكود هيكون كالتالى With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With أنا هحاول بقدر الامكان اعيشك فيديو تشوف الكود اثناء التنفيذ بيعمل ايه السطرالاول هو With ComboBox1 يعنى بنقول للكود الشغل بتاعنا هيكون مع الكمبوبوكس 1 ( الكمبوبوكس المطلوب تعبئته ) السطر الثانى هو الحلقة التكرارية For Each وقمنا بتسميتها اسم افتراضى وليكن Data ( وممكن تسميها اى اسم او حرف او مجموعه من الحروف ) طيب Data وين موجوده فى اى نطاق قلتله فى In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row يعنى النطاق من A2 الى اخر خلية بها بيانات فى العمود A اللى هى بالصوره السابقه A7 ( طبعا عرفنا ازاى نكتب سطر البحث عن اخر خليه بها بيانات) كدا عرفنا النطاق وهيكون من A2 :A7 طبقا للصوره موضوع الشرح ( وطبعا عند زياده المدى وليكن كتابة اسم جديد فى الخلية A8 سوف يقوم الكود بمعرفه النطاق من A2:A8 ) الحلقه دلوقتى عرفت النطاق بتاعها وهتبدأ تلف على خلية خلية فى هذا النطاق وكل مره هيكون الحلقه Data لها اسم خليه معينه فى المره الاولى سيكون قيمة Data هى A2 والكود هينتقل الى السطر التالى وهو i = Data.Row عملت متغير اسمه i وقلت أن i تساوى Data.Row يعنى رقم الصف اللى فيه Data دلوقتى Data هى A2 والخلية A2 كم رقم الصف بتاعها هو الصف رقم 2 أذن i = 2 الكود هيروح للسطر اللى بعد كدا وهو aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) هنا عملت متغير وسميتها aa وقلت ان aa تساوى قيمة معادله ما هى المعادله هى Countif وهى تعنى عمل احصاء على شئ ما داخل نطاق محدد عند الاعلان عن معادله فى اى كود لازم نكتب الجمله دى .Application.WorksheetFunction ثم اسم الداله اللى انت عايزها انا دلوقتى محتاج الداله Countif وهى ( CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data نطاق العمل هو المظلل باللون الاحمر وشرط الاحصاء هو اللون الاخضر جزء النطاق هو ( الى , من )Sheet1.Range السؤال هنا من ايه ؟ الى ايه؟ من A2 بس فى الكود مش هكتبها A2 هستخدم Cells و Cells عباره عن (رقم العمود, رقم الصف)Cells ِA2 كم رقم الصف بتاعها رقم 2 وكم رقم العمود بتاعها رقمه 1 اذن A2 تساوى (Cells(2, 1 الى ايه ؟ الى اى خلية ؟ الى هنا هتكون متغيره انا بالمره الاولى عايزه الى A2 والمره التانيه الى A3 والمره الثالثه الى A4 وهكذا طيب ودى بقى اكتبها ازاى ؟ ركز معايا يا عبدالتواب شايفك نمت منى فى Cells مش احنا قلنا ان Cells عباره عن (رقم العمود, رقم الصف)Cells طيب رقم الصف كل مره هو اللى مش معروف لكن رقم العمود هو اللى معروف طيب اعرف ازاى رقم الصف علشان كدا انا عرفت المتغير i فى السطر الثالث بالكود i = Data.Row فنكتب الى كدا (Cells(i, 1 الصف متغير من خلال i والعمود ثابت وهو عمود A ورقمه 1 اذن النطاق فى اول لفه للكود هيكون من A2:A2 وشرط الاحصاء هو Data اللى هى قيمة الخلية A2 ( عبدالله باقشير) فالمعادله aa هيكون كم 1 طبعا ليه لان عبدالله باقشير فى النطاق من A2:A2 مظهرش غير مره وحده فقط بعد كدا الكود هينتقل الى السطر التالى وهو If aa = 1 Then استخدمت If لاختبار قيمة aa هل هى تساوى 1 أو لا اذا كانت 1 نفذ السطر اللى بعده واذا مش تساوى 1 اقفل if وانتقل الى Next طبعا فى اللفه الاولى اللى احنا فيها دلوقتى aa = 1 فهينفذ المطلوب وهو السطرين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value ترتيب الاعمده فى الكمبوبوكس بيدأ من 0 وكذالك ترتيب الصفوف بيدأ من 0 AddItem هى العمود رقم 0 فى الكمبوبوكس والعمود ده يساوى Data اللى هى كل خليه هتمر فيها الحلقه اللى هى اسماء العملاء بالعمود A والعمود رقم 1 فى الكمبوبوكس هو (List(.ListCount - 1, 1. هيظهر فيه كود العميل اللى بالعمود B (رقم العمود , صفوف الكمبوبوكس)List. صفوف الكمبوبوكس بتبدأ من 0 زى ما قلت علشان كدا قلت ان صفوف الكمبوبوكس - 1 **** ListCount - 1. طيب العمود رقم 1 عايزين نظهر فيه الكود اللى بالعمود B بالشيت فنعمل ايه Data.Offset(0, 1).Value= هنا استخدمنا الداله offset فى اول لفه للحلقه هيكون Data = A2 فأنا بقوله انتقل من A2 بمقدار صف 0 والعمود 1 ( يعنى ايه صف 0 يعنى نفس الصف والعمود واحد يعنى تحرك وروح للعمود B كدا فى اول لفه للحلقه دخل اسم عبدالله باقشير فى العمود الاول للكمبوبوكس ودخل كود العميل وهو 101 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A3 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A3 والخلية A3 كم رقم الصف بتاعها هو الصف رقم 3 أذن i = 3 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 3 اذن (Cells(3, 1 وهى تعنى الخلية A3 يعنى نطاق هو من A2:A3 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A3 (ياسر خليل ) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A3 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل ياسر خليل فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 102 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A4 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A4 والخلية A4 كم رقم الصف بتاعها هو الصف رقم 4 أذن i = 4 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 4 اذن (Cells(4, 1 وهى تعنى الخلية A4 يعنى نطاق هو من A2:A4 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A4 (عبدالله باقشير ) كم مره ظهر اسم عبدالله باقشير فى النطاق من A2:A4 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A5 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A5 والخلية A5 كم رقم الصف بتاعها هو الصف رقم 5 أذن i = 5 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(5, 1 وهى تعنى الخلية A5 يعنى نطاق هو من A2:A5 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A5 (محمد حسن المحمد) كم مره ظهر اسم محمد حسن المحمد فى النطاق من A2:A5 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل محمد حسن المحمد فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 103 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A6 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A6 والخلية A6 كم رقم الصف بتاعها هو الصف رقم 6 أذن i = 6 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(6, 1 وهى تعنى الخلية A6 يعنى نطاق هو من A2:A6 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A6 (عبدالعزيز البسكرى) كم مره ظهر اسم عبدالعزيز البسكرى فى النطاق من A2:A6 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل عبدالعزيز البسكرى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 104 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A7 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A7 والخلية A7 كم رقم الصف بتاعها هو الصف رقم 7 أذن i = 7 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 7 اذن (Cells(7, 1 وهى تعنى الخلية A7 يعنى نطاق هو من A2:A7 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A7 (ياسر خليل) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A7 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next طبعا مش هيرجع فى هذه المره الى الحلقه لان النطاق انتهى وهينتقل الى End With كدا الكود انتهى وانا بصراحه انتهيت معاه من كتر اللف طبعا الكود بينفذ الكلام ده فى لمح البصر دون ان تشعر ولكن لو مساحه النطاق كبير مثلا من A2:A1000 سوف تبدأ تشعر ببطئ الكود ممكن مثلا ياخد 30ثانيه اخر شئ طبعا الكود ده وقت تنفيذه انت اللى بتحدده ولكن على سبيل المثال انا عايز اكتبه فى حدث تشغيل الفورم فيكون كالتالى Private Sub UserForm_Initialize() With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With End Sub وعند تشغيل الفورم ستجد الصوره التاليه لاحظ فى الصوره ان الكمبوبوكس يعرض فقط الاسماء دون تكرار ********************************************************************************************* والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد وطريقه اخرى من طرق تعبئة الكمبوبوكس الطريقه القادمه هنعرف ازاى نجلب البيانات بالكمبوبوكس دون تكرار بطريقه اخرى انتظرونا تقبلوا تحياتى

اخي ياسر يجري هذا الامر لأني اخترت العمر والجنسية ونوع العمل بمعادلة عشوائية و كل شيء يصبح طبيعياً بعد تثبيت البيانات (لاحظ المعادلة في احد هذه الاعمدة من المرفق الاول) تم التعديل show_in top 2.zip

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

أحبتي في الله، وأخي الكريم صاحب الفكرة الرائعة السلام عليكم ورحمة الله لمعالجة مشكلة الاختيار بسهولة من القائمة المنسدلة بكتابة بدايات الحروف، أقوم عادة باستخدام ComboBox (ActiveX control) وأحدد مصدرها مدي معين أي استفسارات تحت أمركم إخوتي

ليس لدى خبرة بالبور بوينت لكن بالمرفق كود يبين ذلك بالاكسيل كود تفعيل 1.rar

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