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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته.. اقدم لكم اداة من برمجتي المتواضعة لتحويل اكواد الـ SQL الى VBA قبل كل شي، الاداة حصراً للمبرمجين الذين يستخدمون الكود في الادراج والتعديل والحذف وليس للأشخاص الذين يستخدمون الواجهة الرسومية للأكسس الخالية من الكود ماهي فائدة الأداة ولماذا استخدمها؟ حسناً، لو كان لدينا جدول اسمة tbl_movementes يقوم بتسجيل جميع الحركات التي تحدث ( اضافة , تعديل , حذف ) وهذا الجدول احتاجه في كثير من النماذج، فهل من المعقول ان اقوم بكتابة عبارة INSERT INTO في كل نموذج ؟ اكيد لا، سأقوم بكتابة Sub واقوم بإستدعاءه كل مرة اريد ان اضيف بها بيانات الى الجدول واختصاراً للوقت الطويل والأخطاء التي ربما ستحدث اثناء عملية التحويل، قمت بكتابة اداة تقوم بهذا الغرض الاداة وضيفتها فقط ( Insert , Update ) صورة الاداة: لنطبق على عملية اضافة بيانات جديد: 1- قم بفتح 2- ثم قم بأختيار الجدول الذي تريده، وقم بإدراج جميع الحقول، كما في الصورة 3- من النافذة العليا اختر النافذة تصميم وقم بتعديل نوع الاستعلام الى استعلام إلحاق وثم بإختيار نفس الجدول لكي يقوم بألحاق البيانات به. الآن لنرى النتيجة 3- الان قم بعرض اكواد الـ SQL 4- قم بنسخ جميع الاكواد كما في الصورة الاتية 5- الان قم بفتح الاداة، واختر النوع Insert، ثم الصق اكواد الـ SQL في مربع النص SQL 6- قبل عملية التحويل قم بإلغاء الأعمدة التي لا ترغب بها من القائمة على اليمين ( Column Remove ) مثلا سأقوم بألغاء العمود IsDeleted وذلك بالضغط على اسم العمود رسالة تخبرك بتأكيد عملية حذف العمود 7- اضغط على الزر Convert 8- تم تحويل الكود ونسخه، الان قم بلصقه في الأكسس واستخدمه الاستخدام النتيجة، تم ادراج البيانات بالجدول لنطبق على عملية تعديل البيانات: نفس الخطوات القديمة فقط من الاداة اختر نوع الاستعلام Update من المعروف ان عملية تعديل البيانات تتطلب معيار للتعديل WHERE COLUMN NAME = Number لذلك عندما نقوم بإنشاء الاستعلام نقوم بوضع عمود المعيار اخر عمود في الاستعلام هكذا من لديه ملاحظات أو اضافات تعطى للبرمج حصراً أحرم تعديل البرنامج بأحد ادوات الهندسة العكسية او نسبه لأي شخص تمت البرمجة حصرياً لمنتدى أوفسينا، اهداء الى معلمي العزيز @jjafferr تحياتي للجميع. SQL-VBA.rar

طيب اتفضل هذا التعديل في البداية انشى Module جديد و الصق فيه التالي Option Explicit Public Function ClenAllTextBox(FormName As String) As String Dim ctrl As Control For Each ctrl In Forms(FormName).Controls If TypeOf ctrl Is TextBox Then Forms(FormName).Controls(ctrl.Name) = Null End If Next ctrl End Function الاستدعاء في اي نموذج لديك Call ClenAllTextBox(Form.Name)

السلام عليكم ورحمة الله إن شاء الله، تجد في الملف المرفق ما تريد... EX (1).xlsx

السلام عليكم ورحمة الله تعديل بسيط في ورقة "سجل أصلي" لرقم الشهر أمام كل جدول للتوقيت (ضروري لعمل المعادلات الجديدة)... شيت جديد 1 - Copy.xlsx

لا يمكن استخدام الكود بهذه الكيفية تفضل الكود بعد التعديل و انصحك بأن تتعلم قراءة الكود لكي تكون على كلم بكل شفرة تستخدمها Sub ClenAllTextBox() Dim ctrl As Control For Each ctrl In Me.Controls If TypeOf ctrl Is TextBox Then Me.Form.Controls(ctrl.Name) = Null End If Next ctrl End Sub و في ازرار الحفظ و في أخر أمر للحفظ استعدي الوظيفة Call ClenAllTextBox

تفضل التعديل اسم المستخدم Admin كملة المرور 123 التقارير والبيانات.zip

وجدت هذا العمل الرائع في الانترنت منذ فترة وقدمه صاحبه مجاناً يرجو الدعاء لوالديه رحمهما الله تعالى :: بيانات صاحب العمل :: عبداللطيف طراقجي 2013و لغاية عام 2000 من عام ً مدرس تكنولوجيا المعلومات سابقا حاصل على شهادات في إدارة قواعد البيانات من شركة مايكروسوفت MCDBA SQLserver (Microsoft Certified Database Administrator) MOUS Access (Microsoft Office User Specialist) صفحته الشخصية My Certifications http://www.pinterest.com/abdotarakji/mycertifications هنا رابط التنزيل ولا تنسوني ووالديه وجميع المسلمين من دعائكم ،،،

ان شاء الله، ترقب النسخة الثانية.

نفس فكرة الأولى إذا فهمت الكود الأول تستطيع بإذن الله أن تصل للكود الثاني

استخدم هذا الفانك ولاحظ التغيرات وحاول فهم التعديل ...... Function kanory1() On Error Resume Next Dim RSB As DAO.Recordset Dim RSD As DAO.Recordset Dim RSJ As DAO.Recordset Set RSB = CurrentDb.OpenRecordset("tblTempS", 2) Set RSD = CurrentDb.OpenRecordset("tblTempe", 2) Set RSJ = CurrentDb.OpenRecordset("tblTempS", 2) Dim I As Integer ', ClassDay As String, BM RSB.MoveLast RSB.Edit RSB!F24 = "الجهة" RSB.Update RSB.MoveFirst '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Do Until RSB.EOF see: If RSB!F24 Like "*الجهة*" Then g = RSB!f7 ' ElseIf RSB!F20 Like "*الخدمة الرئيسية*" Then ' t = RSB!f5 ' ElseIf RSB!F20 Like "*الخدمة الفرعية*" Then ' s = RSB!f6 End If RSB.MoveNext If RSB!F24 Like "*الجهة*" Then GoTo se Loop '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ se: Do Until RSJ.EOF If IsNumeric(RSJ!F25) Then RSD.AddNew RSD!f3 = RSJ!F2 RSD!f4 = RSJ!F25 RSD!f5 = RSJ!F22 RSD!F6 = RSJ!F18 RSD!f7 = RSJ!F16 RSD!F8 = RSJ!f14 RSD!F9 = RSJ!F13 RSD!F10 = RSJ!F10 RSD!f11 = RSJ!F8 RSD!f12 = RSJ!F6 RSD!f1 = g ' RSD!F2 = t ' RSD!f3 = s RSD.Update End If RSJ.MoveNext If RSJ!F24 Like "*الجهة*" Then g = "" t = "" s = "" GoTo see End If Loop DoCmd.OpenTable "tblTempe" DoCmd.Close acForm, "frmdrjat" End Function

بإذن الله هذ الكود يقوم بهذا الترتيب Sub mas_order() For n1 = 1 To 10 Range("a" & n1 * 8 - 4).Value = n1 For n2 = 1 To 3 Range("b" & n1 * 8 - 4 + n2 * 2).Value = n2 * 1000 - 1000 + n1 Next n2: Next n1 MsgBox "Done" End Sub مع إمكانية التحكم في نهاية الترقيم في العمود A بنهاية المتغير n1 في الحلقة التكراربة (حاليا 10) بالتوفيق

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

افضل طريقة ..طريقة د.كاف يار فقد جربتها بعدة طرق لم تنجح Private Sub Firstwork_AfterUpdate() Me.Lastwork = Null End Sub

تم النقل لقسم الإعلانات

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

إن شاء الله تفيدك هذه المعادلات البسيطة حساب تاريخ المعاش.xlsx

اذا كنت تريد مسح الاثنين .. يعني الكمبو والتيكست استخدم الكود التالي Public Sub ClearControls(frm As Form) On Error Resume next Dim objControl as Control For Each objControl in Me.Controls With objControl if .ControlType = acComboBox or acTextbox then .Value = Null end if End With Next objControl End Sub

تفضل التعديل في حدث بعد التحديث ضع التالي [TexBox1]=Null New.accdb

السلام عليكم مجلس الخبراء هل تم استحداث هذا المجلس في اوفيسنا؟

جرب المرفق مستحقات العاملين 1.xlsm

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

أخي الكريم الكود لا يحدد الملف مصدر الأرقام والرسائل الكود يقرأ محتويات الصف السادس حتى الصف 55 في العمود 8 الذي اسمه H والعمود 9 والذي اسمه I من الشيت النشط وبالنسبة لعدم وصول نص الرسالة كاملا تم التغلب عليها بكتابة نص الرسالة في مربع الارسال تلقائيا وعدم إرسالها في الرابط Sub WhatsApp() Dim Contact As String, Message As String Dim n As Long For n = 6 To 7 Contact = Cells(n, 8).Value Message = Cells(n, 9).Value If Contact <> 0 And Message <> "" Then Shell "explorer ""whatsapp://send?phone=" & Contact & """", vbNormalFocus Application.Wait Now() + TimeSerial(0, 0, 5) SendKeys Message Application.Wait Now() + TimeSerial(0, 0, 3) SendKeys "~" Application.Wait Now() + TimeSerial(0, 0, 3) End If Next n MsgBox "Done!" End Sub لاحظ تم حذف المتغير message من رابط الإرسال وكتابته عن طريق الأمر sendkeys وبالنسبة لاحتمالية عدم وجود رقم تم وضع شرط عدم فراغ خلية الرسالة وعدم وجود صفر فقط في خلية الرقم بالتوفيق

السبب: لديك TextBox مكتوب فيه قيمة معينة مثلا.. Forms!frm_home!Age يجب تفريغ جميع مربعات النص، وادراج القيم برمجياً

السلام عليكم ورحمة الله ما تطلبه هنا ليس بالأمر الهين إلا إذا كانت البيانات عمودية لاستعمال خاصية "التبديل" "Convert" أو باستعمال كود VBA... قمت في الملف المرفق ببعض التعديلات على المعادلات (طويلة قليلا) حتى تجلب وقتي الدخول والخروج في ملفك (بالنسبة للخلايا التي تحوي أكثر من توقيتين فإن المعادلات تجلب التوقيت الأول -وقت الدخول- والتوقيت الأخير -وقت خروج-)... وليس لي فكرة أخرى. شيت 1.xlsx

إذا كان برنامج واتس اب للكمبيوتر مثبتا على جهازك يمكنك استخدام هذا الكود Shell "explorer.exe ""whatsapp://send?phone=" & mynumber & "&text=" & mymessage & """", vbNormalFocus حيث mynumber متغير يحمل الرقم مع مفتاح الدولة ومتغير mymessage يحمل نص الرسالة هذا أفضل من هيبرلينك بإذن الله

الحل لهذه المشكلة الا يكون الحقل غير منضم والاعتماد في هذه الحالة عل حقل " تاريخه = odb_Date " فقط وبهذا بمكن التعامل معه مباشرة بدون الحقل الغير منضم واجعله غير قابل للتعديل حتى لا يمكن التعديل على السجلات سواء السابقة او الحالية والاكتفاء بوضع قيمة افتراضية له تاريخ اليوم = date وليس مصدر السجلات تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم التقارير والبيانات.rar ملاحظة : قم بعمل التنسيقات اللازمة لك تحياتي

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

انت معلم و احنا منك نتعلم مشاء الله عليك لست استاذ و لكنك استاذ و رئيس قسم و عميد

مساهمة من العبد لله لإثراء الموضوع تم الاستغناء عن جدول قيم الحروف والزر في النموذج وتم استعمال دالة بسيطة Public Function CharVal(SearchStr) As Long Dim i As Long, myval As Long If Not IsNull(SearchStr) Then Dim d As Object: Set d = CreateObject("Scripting.Dictionary"): d.Add "أ", 1: d.Add "ب", 2: d.Add "ج", 3: d.Add "د", 4: d.Add "ه", 5: d.Add "و", 6: d.Add "ز", 7: d.Add "ح", 8: d.Add "ط", 9: d.Add "ي", 10: d.Add "ك", 20: d.Add "ل", 30: d.Add "م", 40: d.Add "ن", 50: d.Add "س", 60: d.Add "ع", 70: d.Add "ف", 80: d.Add "ص", 90: d.Add "ق", 100: d.Add "ر", 200: d.Add "ش", 300: d.Add "ت", 400: d.Add "ث", 500: d.Add "خ", 600: d.Add "ذ", 700: d.Add "ض", 800: d.Add "ظ", 900: d.Add "غ", 1000: d.Add "ا", 1: d.Add "إ", 1: d.Add "آ", 1: d.Add "ء", 1: d.Add "ى", 10: d.Add "ئ", 10: d.Add "ؤ", 6: d.Add "ة", 5: d.Add " ", 0 For i = 1 To Len(SearchStr) myval = myval + d(Mid(SearchStr, i, 1)) Next i End If CharVal = myval End Function يتم استدعاؤها بعد تحديث مربع النص Private Sub text1_AfterUpdate() Me.text3.Value = CharVal(Me.text1.Value) End Sub تحياتي للجميع mas_charval.mdb

تفضل هذه المشاركة مع الأخوان Dawam1 (1).zip

يمكنك اختيار الشيت وكذلك خلية لليسار واخرى للوسط واخرى لليمين Private Sub CommandButton1_Click() ' prnt Macro With ActiveSheet.PageSetup .LeftHeader = Sheet1.Range("a2") .CenterHeader = Sheet1.Range("b2") .RightFooter = Sheet1.Range("c2") .LeftFooter = Sheet1.Range("a22") .CenterFooter = Sheet1.Range("b22") .RightFooter = Sheet2.Range("a23") End With ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=False End Sub

اعرض الملف تحديد الأوزان النسبية و التقييم + تطبيق بالإكسيل عند مقارنة خيارات متعددة وفقا لمعايير محددة ، يتم أولا تحديد وزن نسبي لكل من هذه المعايير حتى نستطيع الوصول الى قرار و هنا سنعرض لطريقة تحديد الأوزان النسبية ، و من ثم عمل التقييم و طبعا اشهر تطبيق لذلك عند المقارنة بين المتقدمين لمناقصة معينة وفقا لعدة معايير و هنا يشتمل المثال على المقارنة بين عدة أنواع افتراضية من السيارات وفقا لمجموعة من المعايير مثل السعر و الصيانة و درجة الرفاهية و درجة الأمان ، و بناء على ذلك سنتعلم كيف نضع أوزان نسبية لكل من المعايير ، و بناء على ذلك تتم عملية المفاضلة ومرفق مثال بالاكسيل يحوي أتمتة كاملة لتطبيق الطريقة التي تم شرحها فى العرض التقديمي ، يحوى دالتين بالكود تم استخدامهما فى المقارنةو المثال معد بواسطة اكسيل 2007 صاحب الملف محمد طاهر تمت الاضافه 27 مار, 2010 الاقسام Project Management  

لا افهم ما الحاجة الى الحلقات التكرارية في هذه الحالة يكفي هذا الكود بعد تنفيذ الكود يتم استبدال المعادلات بقيمها الحقيقية من خلال الأمر (value=.value.) للتقليل من حجم الملف لانه يحنوي على 10 أعمدة (حيث يوجد معادلات) في كل واحد حوالي 10000 معادلة ( و بذلك لا يتم ارهاق البرنامج بحساب أكثر من 100 الف معادلة مع كل ضربة على الكيبورد او نقرة من الماوس) Sub Get_by_formula() Dim Last_ro%, New_row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Sheets("Sheet3") Last_ro = .Cells(Rows.Count, 1).End(3).Row .Range("O2").Resize(Last_ro - 1, 13).Clear .Range("P2").Resize(Last_ro - 1, 3).Value = _ .Range("A2").Resize(Last_ro - 1, 3).Value .Range("P2").Resize(Last_ro - 1, 3).RemoveDuplicates _ Columns:=Array(1, 2, 3) New_row = .Cells(Rows.Count, "P").End(3).Row With .Range("O2").Resize(New_row - 1, 13) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 12 .InsertIndent 1 .Cells(1, 5).Resize(New_row - 1, 8).Formula = _ "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000),D$2:D$10000)" .Cells(1, 1).Resize(New_row - 1).Formula = _ "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000))" .Cells(1, 13).Resize(New_row - 1).Formula = _ "=ROUND(AVERAGE(S2:Z2),2)" .Value = .Value End With End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الصفحة Sheet3 من هذا الملف Ali_1xlsm.xlsm

تابع معنا طريقة استخدام الدالة VLookUp بعدة طرق لتسهيل التعامل معها والاستفادة منها بأقصى درجة ممكنة من خلال الرابط التالي : https://www.youtube.com/watch?v=eOcLRZuu-54

لا أفهم ما الحاجة الى كل هذه الـــ TextBoxes في الملف في حين يمكن الكتابة رأساً في الخلايا الابتعاد قدر الامكان عن الخلايا المدمجة (تم ازالتها) وضعت لك كود للزر حفظ و يمكن وضع كود مماثل لباقي الأزار Option Explicit Dim Sh1 As Worksheet, Sh2 As Worksheet Dim lr1%, lR2% Dim AR1(), AR2() Dim i%, k% '========================================== Sub Debut() Set Sh1 = Sheets("Sheet1") Set Sh2 = Sheets("Sheet2") lR2 = Sh2.Cells(Rows.Count, 2).End(3).Row + 1 End Sub '============================================= Sub Form_sh1_to_sh2() '+++++++++++++++++++++++++++++++ 'Macro for cmdSave '+++++++++++++++++++++++++++++++++++ Debut AR1 = Array("C6", "C7", "C8", "C9" _ , "C10", "C11", "C12", "C13") AR2 = Array(0, 1, 2, 3, 4, 5, 6, 7) For k = LBound(AR1) To UBound(AR1) Sh2.Cells(lR2, 2).Offset(, AR2(k)) = Sh1.Range(AR1(k)) Sh1.Range(AR1(k)) = vbNullString Next Sh2.Cells(2, 1).Resize(lR2 - 1) = _ Evaluate("row(1:" & lR2 - 1 & ")") End Sub '=========================================== Private Sub cmdSave_Click() Form_sh1_to_sh2 End Sub الملف مرفق allahabi.xlsm

اساتذتنا الكرام هذا الكود يجعل ملف الاكسيل يغلق حسب التاريخ المحدد لكن المشكلة عندما انقله الى جهاز اخر لا يشتغل لان macro غير مفعل كيف يشتغل هذا الكود و الماكرو غير مفعل لعلمكم اني عضو جديد و طرحة مشكلة و لم يجبني احد جزاكم الله خير Private Sub Workbook_Open() If Date > DateValue("08/02/2020") Or Sheets("feuil1").Range("S1") > Date Then Sheets("feuil1").Range("S1") = Date MsgBox " expire ÇäÊåÊ ÕáÇÍíÉ ÇáãáÝ ,ãÓÊÔÇÑ ÇáÊÛÐíÉ ÇáãÏÑÓíÉ", vbYesNo, "" ThisWorkbook.Password = "youyouss" ThisWorkbook.Save Application.Quit End If End Sub

اذا اردت التوزبع عشوائي هذا الماكرو Option Explicit Sub choose_rnd() '============================================= Rem this Macro distributs all numbers bettween Two given Ones _ In Columns with fixed lenght(by Choise) _ without repetition _ ========>> Created by_salim hasbaya On 6/6/2019 '============================================= If ActiveSheet.Name <> "SALIM" Then Exit Sub Dim i% Dim myStart%: myStart = Application.Min([c2:c3]) Dim myEnd%: myEnd = Application.Max([c2:c3]) Range("c2").CurrentRegion.Offset(2, 1).ClearContents If Not IsNumeric([a2]) Or [a2] < 1 _ Or Int([a2]) <> [a2] Then [a2] = 50 Dim Max_ro%: Max_ro = [a2] + 2 If Max_ro > 102 Then Max_ro = 52 Dim r%, c% r = 3: c = 4 With CreateObject("System.Collections.SortedList") For i = myStart To myEnd .Item(Rnd) = i Next i i = 0 Do Until i > .Count - 1 Cells(r, c) = .GetByIndex(i) r = r + 1 If r = Max_ro + 1 Then r = 3: c = c + 1 i = i + 1 Loop End With End Sub الملف مرفق Rnd _Distribution.xlsm

اخي ضع في الخلية B2 بداية الارقام وفي الخليةة B3 ضع الرقم الذي ستنتهي عنده الارقام ثم اضغط علي زر توزيع ارجو ان يكون المطلوب مصفوفة.xlsm

بارك الله فيك استاذى الكريم بن علية وهذه معادلة اخرى لإثراء الموضوع bachiri401.xlsx

السلام عليكم بعض التعديلات تمت على الملف... راجع الملف المرفق. القوائم جعلتها تتغير حسب القائمة المنسدلة للأقسام (الخلية A1). لأي استفسار أو إضافات تجدني إن شاء الله في الخدمة... بن علية حاجي 1علوم.xlsx

السلام عليكم .. في المرفقات ملفي إكسل يتضمنان أمري فيجوال بيزك لتعطيل الاختصارات و تفعليها . مصدر الأوامر موقعStack overflow ملاحظة يجب حفظ ملف الإكسل بعد وضع الكود فيه بامتداد Macro-Enabled Worksheet (.xlsm) رجائي ممن يستفيد من هذه الملفات دعوة صالحة و أمنية طيبة بالغيب ... شكراً لكم و لكم الفضل في ذلك . تعطيل كنترول.xlsm تعطيل معظم الاختصارات.xlsm

السلام عليكم أخوتى ورحمة الله وبركاته كلنا يعرف يشغل ماكرو لكن هل فكرت تعمل باسوورد للماكرو ؟!!!!!!!!!!!!!!!!!!!!!!!!!! ماشى البعض منا يعرف يسوق عربية - أنا مش منهم - لكن هل فكرت أنك تعمل باسوورد لعربيتك ؟!!!!!!!!!!!!!!!!! حمل المرفق وهتعرف كل شىء الكود الأساسى المستخدم بسيط : Sub passtorunmacro() Dim MyPassword MyPassword = InputBox("من فضلك أدخل كلمة سر تشغيل الماكرو ", "كلمة السر", "********") 'باسوورد الماكرو If MyPassword = "123" Then MsgBox "كلمة السر صحيحة. لتشغيل الماكرو اضغط موافق", vbInformation, "دخول" 'استدعاء الماكرو Call Shape Exit Sub Else MsgBox "كلمة السر خاطئة", vbCritical, "خطأ" Exit Sub End If End Sub وهذا هو البنزين90 عفواً أقصد الكود الفرعى الذى نستدعيه لتحريك العربية : Sub Shape() Dim i As Integer Dim j As Integer With ActiveSheet.Shapes("Picture1") For j = 1 To 10 For i = 1 To 300 .IncrementLeft 0.75 DoEvents Next i For i = 1 To 300 .IncrementLeft -0.75 DoEvents Next i Next j End With End Sub اللى تعجبه الفكرة يدعو لى أتعلم السواقة , وأشترى عربية Enter Password to run a Macro.rar

الاخ مختار شكرا لكلاماتك اضافة بسيطة نتمنى تعجبك Enter Password to run a Macro.rar