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

مرحبا ابو جودي ( طلبت عدم ذكر القاب وانت اهل لها ) ايش رايك نطبق محليا اولا ! وبدون سيرفر ! اقصد تنفيذ استعلام معقد محليا وهناك تاخر به وظهور بروقرس بار يبن العملية ؟ تحياتي

اخي شيفان الاولى ان لاتقيد نفسك بالتكبيق الذي استخدمة به الجملة وهي تسمى جملة التكرار فور هذه نقاط لعل لك بها فائدة 1. استفيد من الجملة في: - اريد تكرار مجموعة من الاوامر البرمجية وبتغير متغيرات بداخلها بكل لفة - قيمة العداد حيث ينحصر بين قيمتين 2. يكون العداد من الرقم الاصغر للاكبر دائما . وعند البدء بقيمة سالبة فعليك الانتباه الى ان معروف ان الرقم الاصغر باشارة سالب هو الاكبر فلو عملت فور لوب بالشكل التالي for i=-3 to 2 فاول قيمة للعداد هي -3 ثم -2 .... ثم الصفر واخيرا حتى 2 3. هناك خاصية مقدار القفز في الدوران وهي تتم باضافة step ثم قيمة القفز فمثلا for i=1 to 5 step 2 سيتم الدوران ثلاث مرات فقط لان المرة الاولى قيمة العداد 1 ثم 3 ثم 5 وحسب قيمة القفز تحياتي

السلام عليكم ورحمة الله وبركاته كود البحث المتقدم باستخدام المصفوفات VBA Arrays قدم لنا الأخ الغالي ياسر العربي صاحب الجولات والصولات كود رائع ، ويستخدم الكود في البحث المتقدم ، وقد استخدم المصفوفات والتي هي عشقي في التعامل مع الأكواد ، حيث يتم تنفيذ جميع أسطر الكود بالذاكرة بعيداً عن التعامل بشكل مباشر مع ورقة العمل ، مما يجعل الكود أسرع مئات المرات من استخدام الحلقات التكرارية العادية. وقد ارتأيت أن أقوم بشرح لأسطر الكود ليكون مرجع لكل طالب علم ولكل باحث في هذا الخصوص ، ولنبدأ مرحلة جديدة من عالم الأكواد باستخدام المصفوفات VBA Arrays ، لما لها من مرونة عالية وسرعة فائقة في تنفيذ الأكواد. يوجد بالمرفق ورقتي عمل أحدهما باسم Data وفيها البيانات الخام من 14 عمود ، والورقة الأخرى باسم Result للنتائج وبها الخلية G2 والتي توضع بها نص الكلمة المراد البحث عنها. وإليكم الكود مع الشرح بالتفصيل (وضعت مثال بسيط ليستطيع المتتبع للشرح فهم الكود بسهولة) Sub Araby_Search() 'تعريف المتغير لورقة العمل التي تحتوي على البيانات الخام Dim wsData As Worksheet 'تعريف المتغير لورقة العمـل المطلـوب إظهـار النتائـج بها Dim wsResult As Worksheet 'تعريف المتغير ليحمل قيم المصفـوفة للبيانات الخـام Dim Arr As Variant 'تعريف المتغير ليحمل قيم المصفوفة للنتائج المطلوبة Dim Temp As Variant 'تعريـف المتغير من النـوع النصي ليحمـل قيمة أو نص البحث 'أي الكلمة المطلوب البحث عنها يتم تخزينها في هذا المتغير Dim strSearch As String 'تعريف المتغير وسيستخدم في الحلقة التكرارية لصفوف المصفوفة Dim I As Long 'تعريف المتغير وسيستخدم في الحلقة التكرارية لأعمدة المصفوفة Dim J As Long 'تعريف المتغير وسيستخدم في مصفوفة النتائج لزيادة مقدار الصفوف بمقدار واحد Dim P As Long 'تعيين قيمة للمتغير ليساوي ورقة العمل التي تحتوي '[Data] على البيانات الخام المطلوب معالجتها والمسماة Set wsData = Worksheets("Data") 'تعيين قيمة للمتغير ليساوي ورقة العمل التي تريد إظهار '[G2] النتائج بها بمجرد إدخال قيمة أو نص محدد في الخلية Set wsResult = Worksheets("Result") 'مسح النطاق الذي توضع فيه النتائج استعداداً لوضع النتائج الجديدة wsResult.Range("A8:N10000").ClearContents '[G2] تعيين قيمة للمتغير ليساوي قيمة الخلية 'وهي الخلية التي ستوضع فيها نص الكلمة المطلوب البحث عنها strSearch = wsResult.Range("G2").Value 'تعيين قيمـة للمتغير ليحمل قيم النطاق بالكامل للبيانات الخام ' وذلك [Data] حيث أن مصـدر البيانات الخام ورقة العمل المسماة 'عند [N] وينتهي في العمود [A5] في النطاق الذي يبدأ من الخلية '[&] آخـر صف به بيانات ، ويتم تحديده عن طريـق الجزء بعد علامـة Arr = wsData.Range("A5:N" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value 'والتي ستحمل قيم النتائج [Temp] إعادة تعيين أبعاد المصفوفة المسماة '[Arr] وتكون بنفس أبعاد المصفوفة التي تحمل البيانات الخام والمسماة 'سنعتبر المصفوفة أشبـه بالصفـوف والأعمدة حيث الرقـم 1 يمثـل الصفـوف 'بإرجاع أكبر قيمة [UBound]بينما الرقم 2 يمثل الأعمدة ، وتقوم الكلمة 'أبعاد المصفوفة في هذه الحالة >> '------------------------------- 'البعد الأول سيكون من 1 إلى أكبر قيمة للصفوف 'البعد الثاني سيكون من 1 إلى أكبر قيمة للأعمدة ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) 'حلقة تكرارية من الصف الأول للمصفوفة إلى آخر صف بها For I = 1 To UBound(Arr, 1) 'إذا كان النص المطلوب البحث عنه فارغ يتم الخروج من تنفيذ الكود If strSearch = "" Then Exit Sub 'هذا السطر هو أهم سطر بالكود حيث هو الشرط الذي من خلاله 'والشرط [Temp] ستوضع النتائج في مصفوفة النتائج المسماة 'هـو تطابق قيمة المصفوفة في صف الحلقة في العمود رقم 14 'حيث يمثـل الرقم 14 العمود داخـل مصفوفة البيانات الخام '[strSearch] يتـم اختبـار التطابـق مع نـص البحث المسمى If Arr(I, 14) Like "*" & strSearch & "*" Then 'زيادة مقدار المتغير بمقدار 1 'فائدة المتغير هنا هو أنه مع كل حلقة تكرارية 'إذا تحقق الشرط فقط يزيد المتغير بمقدار واحد 'ليمثل هذا المتغير صفوف مصفوفة النتائج الجديدة P = P + 1 'حلقة تكرارية داخلية من العمود الأول للمصفوفة إلى آخر عمود بها For J = 1 To UBound(Arr, 2) 'تعبئـة مصفـوفة النتائـج بالبيانات مـن مصفوفة البيانات الخام '[Temp]مثـال لتتضح صورة كيفية تعبئة المصفوفة الجديدة المسماة 'في أول حلقـة سيكون مقداره 1 ويمثل أول صف [P] المتغيـر المسمى 'أول صف هنا لمصفوفة النتائج 'في أول حلقة سيكون مقداره 1 ويمثل أول عمود [J] المتغير المسمى 'في أول حلقة سيكون مقداره 1 ويمثل أول صف [I] المتغير المسمى 'أول صف هنا لمصفوفة البيانات الخام Temp(P, J) = Arr(I, J) 'الانتقال للحلقة التالية للأعمدة Next J 'نهاية جملة الشرط وهو تطابق نص البحث مع العمود رقم 14 في المصفوفة End If 'الانتقال للحلقة التالية في صفوف مصفوفة البيانات الخام Next I 'إذا كانت قيمة المتغير أكبر من صفر فهذا يعني أنه تم إيجاد نتائج للبحث 'حيث أن زيادة المتغير كما أوضحنا مقرونة بتحقق الشرط وطالما تحقق الشرط 'فهذا يعني أن مصفوفة النتائج سيكون بها بيانات ومن ثم يتحقق الجزء الثاني '[A8] وضع نتائج مصفوفة النتائج في أول خلية في ورقة النتائج في الخلية '[P] ويتم تمديد النطاق بمقدار عدد الصفوف طبقاً لقيمة المتغير المسمى '[Temp] وبمقدار عدد الأعمدة طبقاً لأكبر عدد لأعمدة المصفوفة المسماة If P > 0 Then wsResult.Range("A8").Resize(P, UBound(Temp, 2)).Value = Temp End Sub لتحميل الملف المرفق وللإطلاع على الموضوع الأصلي قم بزيارة الرابط التالي رابط الموضوع من هنا

فكرة حلوة ويمكن الاستمرار بان ياخذ الامر نص الاختيار عنوانا Private Sub cmb_Committe_AfterUpdate() btn_DropCommittee.Caption = cmb_Committe End Sub بالتوفيق

اخي عبدالعزيز هذا المطلوب ختلف عن المطلوب باول مشاركة ! واعتقد ان الاستاذ شيفان اجاب على اخر طلب وهناك فكرة ان تربط الترقيم بان السجل جديد ليصبح كود بعد التحديث لاسم ولي الامر كالتالي Private Sub FATHER_NAME_AfterUpdate() Rem تعبئة حقول محددة من مربع الالتحرير والسرد ' Me.SONS = Me.FATHER_NAME.Column(1) ' Me.PHONE = Me.FATHER_NAME.Column(2) ' Me.INSTALLMENTS = Me.FATHER_NAME.Column(3) Rem ترقيم آلي If Me.NewRecord Then Me!NUM_PAID = Nz(DMax("[num_Paid]", "[TabPaids]"), 0) + 1 End Sub بالتوفيق

بقالى نصف ساعة على الصفحة عشان اعمل مشاركة النت سلحفاة اضافة الى كلام أستاذى الفاضل جرب الكود التالى على ملفك الكود يؤكد أن المسافة الفارغة لها قيمة عند اكسل Sub Test2() Dim Cel As Range For Each Cel In Range("A2:A29") Cel.Offset(, 3).Value = Len(Cel) & " " & " حرف بالمسافات" Cel.Offset(, 4).Value = Len(Replace(Cel, " ", "")) & " " & "حرف بدون المسافات" Next Cel Cells.ShrinkToFit = True End Sub

الاحتمالات.rar

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

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

انت انسان رائع

حبيبي ابو البراء معلش بقى مكان ما تحط تشفيرك احط تشفيري تفضلو تشفير كل انواع الملفات ولا يستطيع احد فتحها من الخارج http://yasserelaraby86.blogspot.com.eg/2016/04/blog-post_24.html تقبل تحياتي

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

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

السلام عليكم استفدت مؤخرا بكود ممتاز لـ TEXT BOX أمكنني من البحث بمجرد كتابة الحرف الأول فقط ... للأسف لا أذكر من صاحبه لأشكره على مجهوده. المطلوب تعديل لهذا الكود بحيث يبحث عن الكلمة في كل الخلية وليس الأحرف الابتدائية لها فقط . الكود هو : Private Sub TextBox1_Change() Dim lastrow As Long lastrow = Range("N65535").End(xlUp).Row If ActiveSheet.TextBox1.Text <> "" Then Range("$A$2:$R$" & lastrow).AutoFilter Field:=14, Criteria1:= _ "=" & TextBox1.Text & "*", Operator:=xlOr Else Range("$A$2:$R$" & lastrow).AutoFilter Field:=14, Criteria1:= _ "=" & ActiveSheet.TextBox1.Text & "*", Operator:=xlOr End If End Sub ولكم جزيل الشكر

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

أخى الفاضل / ناصر سعيد السلام عليكم ورحمة الله وبركاته أعتذر كثيرًا عن تأخرى فى الرد على مشاركتكم الغالية للموضوع المطروح هناك سببان مهمان من وجهة نظرى لعدم ترك الملف مفتوح بدون تشفير وهما : 1ــ هذا الملف مرفوع للنشر والاستخدام العام سواء اعضاء المنتدى الكرام ذوى الخبرة الواسعة فى هذا المجال أو لغيرهم من ذوى الخبرة القليلة ؛ لذا آثــرت أن أتركه مشفرًا لعدم العبث فيه ( بغير قصد من ذوى الخبرة القليلة ) لأنه كما تعلمون أن أى عبث فى اى معادلة تفسد درجات الطلاب جميعهم. 2 - والسبب الآخر أن هذا املف مشفر باكثر من كلمة مرور ( حيث أنه مقسم إلى مجموعات كل مجموعة لها كلمة مرور خاصة ، وليست كلمة واحدة ) وليس السبب أنى أريد أن أستأثر بهذا العلم فهذا العلم إنما وفقنى إليه ربى بمساعدتكم أنتم أعضاء المنتدى الكرام وبخبراتكم الواسعة وتشجيعكم الدائم وقد قمت بمشاركات عديدة قدمت فيها حلولا لبعض المسائل المطروحة فى هذا المنتدى ( على قدر خبرتى القليلة ) ولم أبخل بعلم آتى اله إياه تقبل اعتذارى عن تأخرى للرد ، ووافر احترامى أخى الفاضل

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

استاذنا الحبيب ومعلمنا القدير انا فى الانتظار لان بصراحة انا بحست مطولا فى هذا الموضوع ولم اصل لشئ

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

في هذا الملف البيانات في صفحة اخرى اخي ياسر ليس من الضرورة لهكذا معادلة طويلة (نسيت ان اضرب النتيجة بقيمة الخلية b&12 $ ) لتصبح هكذا =INDEX($A4:$I4,2*(COLUMNS($A$1:A1)-1)+3)*(1+$B$12) النسخ salim.rar

ههههههههههههههه ربنا ما يحرمنا من لمساتك الرمهانية جزاكم الله خيرا دائما وابدا هناك لمسات رمهانية وادى المرفق الرمهانى Test_2.rar

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

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

السلام عليكم ورحمة الله وبركاتة مرفق اليك الحل الملف المرفق : فاتورة.rar

تفضل اخي العزيز ارجو ان يكون طلبك asd.rar

ما شاء الله كود ولا أروع ، وسرعة ما لها حل .... وصدق أخي @قلم-الاكسل(عبدالعزيز) فلا ندري نشكر من صاحب الشرح أم صاحب الكود ! فالشكر للاثنين معا جزاهم الله خيرا وزادهما من علمه

الله يرضى عليكم جميعا وعلى هذا المنتدى الرائع

وعليكم السلام أخي الكريم وائل جرب الكود التالي .. وحاول أن تضع شكل المخرجات إذا لم يؤدي الكود الغرض Sub Test() Dim Cel As Range For Each Cel In Range("A1:A29") If Len(Cel) >= 255 Then Cel.Offset(, 1).Value = Cel.Value Cel.ClearContents End If Next Cel End Sub

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

السلام عليكم الله يرضى عليك استاذ ياسر جزيت خيرا

وعليك السلام أخى الحبيب حسام أنا في العمل الآن والجيميل لا يفتح معى حالما ارجع للبيت خلال ساعتين إن شاء الله سأطلع على الميل أما بالنسبة لاستفسارك عن البرنامج فلا أعرف أى البرنامجين تقصد ولا طبيع ونوع الخطأ الذى يظهر وعموما فإذا كان البرنامج القديم 29-9-2016 Trip To Paradise فقد كان يعمل دون رسائل خطأ وأما إن كان برنامجك الجديد Foaid2 فقد لاحظت وأن أعمل عليه بعض الملاحظات منها أنه ليس به علاقات بين جداول العناوين وأنك أذا حذفت العناوين لتصفير الترقيم التلقائى وعمل ضغط وإصلاح لقاعدة البيانات ووضعت عناوين جديدة في جداول العناوين فالشجرة لا تعمل وتعطى بعض رسائل الخطأ في بنيه الكود

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

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة تشفير وفك تشفير البيانات Encrypt And Decrypt Function تم ارفاق ملف جديد لنفس الموضوع من الفاضل _ أ / ياسر العربى تفضلو تشفير كل انواع الملفات ولا يستطيع احد فتحها من الخارج http://yasserelaraby86.blogspot.com.eg/2016/04/blog-post_24.html و لا تنسونا من صالح الدعاء تحياتى الاحتمالات.rar

السلام عليكم ورحمة الله وبركاته هل لديك بيانات حساسة ومهمة في ورقة العمل تريد ألا يطلع عليها أحد؟ طرق الحماية للإكسيل كما يعرف الجميع ضعيفة ، لذا فإن تشفير البيانات هو الحل الأمثل للوصول إلى حماية أفضل للبيانات. إخواني الكرام أقدم لكم طريقة لتشفير البيانات في ملفك ، وبنفس الكود ستتمكن من فك تشفير البيانات. خطوات العمل : >> قم بالدخول لمحرر الأكواد عن طريق Alt + F11 ، ثم من قائمة Insert أدرج موديول جديد Module ، وأخيراً الصق الكود التالي داخل الموديول. >> قم برسم زر أمر على ورقة العمل ، ثم كليك يمين على الزر واختر الأمر Assign Macro ثم اختر الإجراء الفرعي المسمى Encrypt_Decrypt Sub Encrypt_Decrypt() Dim xRg As Range Dim xPsd As String Dim xTxt As String Dim xEnc As Boolean Dim xRet As Variant Dim xCell As Range On Error Resume Next xTxt = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Select A Range:", "Select Range To Encrypt / Decrypt", xTxt, , , , , 8) Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange) If xRg Is Nothing Then Exit Sub xPsd = InputBox("Enter Password:", "Pass Entry") If xPsd = "" Then MsgBox "Password Cannot Be Empty", , "Kutools For Excel" Exit Sub End If xRet = Application.InputBox("Type 1 To Encrypt Cell(s)" & vbNewLine & vbNewLine & "Type 2 To Decrypt Cell(s)", "Encrypt = 1 / Decrypt = 2", , , , , , 1) If TypeName(xRet) = "Boolean" Then Exit Sub If xRet > 0 Then xEnc = (xRet Mod 2 = 1) For Each xCell In xRg If xCell.Value <> "" Then xCell.Value = Encryption(xPsd, xCell.Value, xEnc) End If Next xCell End If End Sub Private Function StrToPsd(ByVal Txt As String) As Long Dim xVal As Long Dim xCh As Long Dim xSft1 As Long Dim xSft2 As Long Dim I As Integer Dim xLen As Integer xLen = Len(Txt) For I = 1 To xLen xCh = Asc(Mid$(Txt, I, 1)) xVal = xVal Xor (xCh * 2 ^ xSft1) xVal = xVal Xor (xCh * 2 ^ xSft2) xSft1 = (xSft1 + 7) Mod 19 xSft2 = (xSft2 + 13) Mod 23 Next I StrToPsd = xVal End Function Private Function Encryption(ByVal Psd As String, ByVal InTxt As String, Optional ByVal Enc As Boolean = True) As String Dim xOffset As Long Dim xLen As Integer Dim I As Integer Dim xCh As Integer Dim xOutTxt As String xOffset = StrToPsd(Psd) Rnd -1 Randomize xOffset xLen = Len(InTxt) For I = 1 To xLen xCh = Asc(Mid$(InTxt, I, 1)) If xCh >= 32 And xCh <= 126 Then xCh = xCh - 32 xOffset = Int((96) * Rnd) If Enc Then xCh = ((xCh + xOffset) Mod 95) Else xCh = ((xCh - xOffset) Mod 95) If xCh < 0 Then xCh = xCh + 95 End If xCh = xCh + 32 xOutTxt = xOutTxt & Chr$(xCh) End If Next I Encryption = xOutTxt End Function شرح كيفية استخدام الكود : لتشفير البيانات : حدد النطاق أو الخلايا المراد تشفير البيانات بها ، انقر على زر الأمر ليظهر لك صندوق إدخال يمكنك من خلاله تحديد النطاق ، وبما أنك قمت بتحديد النطاق في البداية فلن يكون لديك سوى أن تنقر OK ، لتنتقل إلى صندوق إدخال آخر بعنوان Pass Entry ومن خلاله تدخل كلمة السر للتشفير ، وليكن 111 ، ثم انقر OK الآن سيظهر آخر صندوق إدخال وهو لإدخال الرقم 1 (للتشفير) ، أو الرقم 2 (لفك التشفير) بما أننا نريد التشفير سنقوم بكتابة الرقم 1 ثم ننقر OK ، ولاحظ البيانات في النطاق (لقد تم الأمر بحمد الله) لفك التشفير : ستقوم بتكرار نفس الخطوات بالضبط وتدخل نفس كلمة السر ، وفي آخر صندوق إدخال ستقوم بإدخال الرقم 2 لفك التشفير وأخيراً إليكم صورة توضيحية لكيفية التعامل مع الكود لتحميل الملف المرفق قم بزيارة الرابط للموضوع رابط الموضوع من هنا

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

اتفضل اخي حسب فهمي لطلبك اذا بيكون رقم السند موجود ما يتغير الرقم السند حين تم تعديل على اسم واذا بيكون فارغ راح يزيد رقم واحد على اخر رقم واذا تريد تتغير رقم السند ما تكدر الا برقم سري الا وهو 0000 واذا دخل رقم خطا راح يكلك الرقم سري خطأ ولا تكدر تتغير رقم السند مع شكر وتقدير اخوك : شفان ريكانى Aziz.rar

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

مرحبا تقريا نفس الكود الذي وضعه اخي ياسر Sub ColorRange() Application.ScreenUpdating = False Dim c1 As Range, c2 As Range Range("b3:i16").Interior.ColorIndex = xlNone: Range("b3:i16").Font.ColorIndex = 1 For Each c1 In Range("b3:i16"): For Each c2 In Range("b3:i16") If Val(c1.Value) + Val(c2.Value) = Range("a2").Value Then x = Int(Rnd * 55) c1.Interior.ColorIndex = Val(x): c2.Interior.ColorIndex = Val(x) End If If c1.Value = Range("a2").Value Then c1.Font.ColorIndex = 46 If c2.Value = Range("a2").Value Then c2.Font.ColorIndex = 46 Next Next Application.ScreenUpdating = True End Sub

جزيت خيرا اخي الغالي ابو البراء على الشرح الوافي تقبل تحياتي

وعليكم السلام قم بسحب المعادلة في الملف الذي أرفقته إلى آخر المدى المطلوب .....

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

- المطالبة ببيانات الشركة / المؤسسة عند فتح القاعدة للمرة الاولى - نسخة تجريبية للسنة الحالية فقط حتى لو تم التلاعب بتاريخ النظام بالتقديم والتاخير فى شاشة اتفاقية الترخيصعند الضغط على الرز (F6) سوف تتم فتح نافذة لو تم تغيير التاريخ الى الى سنة 2016سوف يعمل البرنامج بنجاح - اخفاء اطارات الاكسس - انشاء مجلدات تخص نظم قاعدة البيانات -مشاركة الصور بحفظ مسارتها داخل المجلد الخاص بها بنفس مسار القاعدة -عرض الصور على الشبكة دون تغييرها او تغيير مسارها او تعديله او دون اى تدخل من المبرمج بدون عناء ( تصلح لصور الموظفين) تم ادراج نموذج يتحكم بكل صغيرة وكبيرة فى القاعدة لزيادة الحماية ملحوظة : القاعدة لن تعمل عند محاولة تغيير اسمها لم اخفى كل كائنات القاعدة بلا رجعة لم اقم بغلاق زر الشيفت demo.rar

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

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

you welcome in times to come, please try to choose a suitable name for the subject because it bases posts in forums and we must all respect for those rules do not put your address is not suitable for the subject, as it did and you would have your own e-mail regarding the arabization list you can search the internet for the arabization of office suit version you are using, and so are all the menus to translate the arabic language that you want it as he can switch between languages when you want to after that with ease

ربما يكون هذا الكود (المرفق)اسرع قليلاً SERCH_ARRY salim.rar

تحياتى لك أخى و حبيبى ياسر الحل المقدم من حضرتك أكثر من رائع تم اضافة جمع الاصناف فى كل صف استفسار أستاذى الفاضل حاولت استخدام المصفوفات فـ كيف استخدم المصفوفات فى حاجة زى كده ؟ استخراج الحقول ذات القيم بالترتيب وتجاهل الخلايا الفارغة.rar

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

أخي الكريم محمد أهلا بك في المنتدى ونورت بين إخوانك الموضوع مشروح بالتفصيل في الموضوع على هذا الرابط الرابط من هنا تقبل تحياتي

حبيبى الغالى أستاذى ومعلمى القدير / ياسر خليل كل سنة وحضرتك بألف صحة وسلامة وربنا يجعلها سنة سعيدة عليك قمت بعمل الخطوات ولكن عند إختيار Field Settings لم يظهر لى نافذة فيها كلمة Number Format ولكن يظهر لى الشاشة الأتية ولم أجد القسم Custom واكتب mmm ويوجد فى الصورة السابقة Custom ولكن ليس بها إختيار للكتابة الرجاء الإفادة