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

وعليكم السلام 🙂 معذرة اخوي خالد ، بدل ما يستعمل اخوي ازهر كودك ابو 8 اسطر ، انا اقدم له حل ابو سطر واحد فقط ، ويشتغل في الكود والاستعلام Remove_Letters: Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace("y0372023r0b9g0v5", "q", ""), "w", ""), "e", ""), "r", ""), "t", ""), "y", ""), "u", ""), "i", ""), "o", ""), "p", ""), "a", ""), "s", ""), "d", ""), "f", ""), "g", ""), "h", ""), "j", ""), "k", ""), "l", ""), "z", ""), "x", ""), "c", ""), "v", ""), "b", ""), "n", ""), "m", "") جعفر الحروف على تسلسل لوحة المفاتيح 🙂

ابحث عن هذا With imsg With imsg .to = StudentEmaile .from = DLookup("settingsUsername", "settings", "settingNO=1") .Subject = "ÔåÇÏÉ" .HTMLBody = Mymsg .AddAttachment (MyAttachment) Set .Configuration = iconf .Send End With واستبدله بهذا ..... With imsg .BodyPart.Charset = "UTF-8" .to = StudentEmaile .from = DLookup("settingsUsername", "settings", "settingNO=1") .Subject = "ÔåÇÏÉ" .HTMLBody = Mymsg .AddAttachment (MyAttachment) Set .Configuration = iconf .Send End With تم اضافة هذا السطر .BodyPart.Charset = "UTF-8"

السلام عليكم 🙂 اليك طريقة نقل كائنات المرفق الى برنامجك ، لأن نقل الوحدة النمطية التي في Class من برنامج الى آخر يجب ان يتم بطريقة خاصة : هذه المشاركة الاصل ، وفيها المرفق بصيغة 2003 🙂 جعفر

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

بخصوص كود الاستاذ جعفر جزاه الله عني كل خير

يامرحبا ترحيبة كلها لك انا اقول لك جرب كودك في استعلام بعد اسنادة لحقل النص المطلوب تعديله سوف يعمل ببطء شديد وكل ماكانت السجلات اكثر يكون اكثر بطء ثانيا انت استخدمت دالة الاستبدال بعدد احرف الهجائية الانجليزية وبالتالي عدد احرف الكود لديك اكبر ههههههه ثالثا لو كان الحقول مختلطة باحرف ورموز كودك استاذنا لن يعمل حتى تقوم باضافة هذه الرموز رابعا لو كانت بعض الحقول تحتوي على احرف عربية ايضا لن يعمل وسيكون لدينا حمسين Replace اما بشأن العمل في الاستعلام فالاستاذ ازهر لم يحدد ويمكن بتعديل بسيط تعديله الى وحدة نمطية وسوف يعمل Public Function ExNum(sInput) As String Dim s As String, w As String Dim k As Integer If Not IsNull(sInput) Then For k = 1 To Len(sInput) w = Mid(sInput, k, 1) Select Case w Case "0" To "9" s = s & w Case Else End Select Next k End If ExNum = s End Function وللاستدعاء exnum([tx]) وكل عام وانت بخير

ربما هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Large_RG As Range Dim Unique_RG As Range Dim Empty_String$, Other__String$ Dim Option_string$ Dim Position% Const m = 2 Empty_String = "": Other__String$ = "Hirassa" Set Large_RG = Range("Q9:Y300") Set Unique_RG = Range("G3") Dim q%, r%, S%, t%, u%, v%, W%, x%, y% q = 17: r = 18: S = 19: t = 20 u = 21: v = 22: W = 23: x = 24: y = 25 Application.EnableEvents = False If Not Intersect(Target, Unique_RG) Is Nothing _ And Target.Cells.Count = 1 Then Range("D8") = Other__String End If If Not Intersect(Target, Large_RG) Is Nothing _ And Target.Cells.Count = 1 Then Select Case Target.Column Case q: Option_string = Empty_String: Position = q - 2 * m Case r: Option_string = Empty_String: Position = r - 3 * m Case S: Option_string = Empty_String: Position = S - 4 * m Case t: Option_string = Empty_String: Position = t - 5 * m Case u: Option_string = Empty_String: Position = u - 6 * m Case v: Option_string = Empty_String: Position = v - 7 * m Case W: Option_string = Empty_String: Position = W - 8 * m Case x: Option_string = Empty_String: Position = x - 9 * m Case y: Option_string = Empty_String: Position = y - 10 * m End Select If Target = "a" Then Target.Offset(, Position) = Empty_String End If End If Application.EnableEvents = True End Sub الملف Joe_code.xlsm

الاستاذ kha9009lid جزاك الله عني كل خير

اتمني يكون المطلوب ‫‫‫‫‫‫‫‫قاعدة الدورات التدريبية 5 والاخيرة - نسخة.rar

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

تمام انا كنت لسا براجع ان شاء الله نجد المشكلة .

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

جرب هذا الملف Data_Val_Jo.xlsm

جرب Dim k As Integer Dim x As Integer For k = 1 To Len(tx) x = Asc(Mid(tx, k)) If x >= 48 And x <= 58 Then Me.tx2 = tx2 & Mid(tx, k, 1) End If Next k مرفق مثال Database1641.accdb

تم التعذيل على الماكروات Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Private Sub Fnd_change() Debut Dim R1%, R2% Me.ListBox1.RowSource = "" If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd & "*", Lookat:=2) If Not F Is Nothing Then R1 = F.Row: R2 = R1 Do With Me.ListBox1 .AddItem For i = 0 To .ColumnCount - 1 .List(.ListCount - 1, i) = sh.Cells(R2, 1).Offset(, i) Next Set F = sh.Range("A1:A" & Ro).FindNext(F) R2 = F.Row If R2 = R1 Then Exit Do End With Loop End If End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut Dim t% If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub t = Me.ListBox1.ListIndex Set F = sh.Range("A1:A" & Ro).Find(Me.ListBox1.List(t, 0), Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut Dim t%, st If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub t = Me.ListBox1.ListIndex st = Me.ListBox1.List(t, 0) Set F = sh.Range("A1:A" & Ro).Find(st, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete Me.ListBox1.RemoveItem (t) ListBox1.ListIndex = -1 For i = 0 To 6 Me.Controls(Arr_text(i)) = "" Next MsgBox "the Item " & """" & st & """" & Chr(10) & _ "with address " & """" & sh.Cells(K, 1).Resize(, 7).Address(0, 0) _ & """" & " Is Deleted", 64 Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف من جديد My_ListBox_1.xlsm

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

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

الاخ@صالح حمادي قد يفيدك هذا الرابط

جرب المرفق زر تعديل يقوم بتعديل في جميع الشيتات بناء على الاسم المختار في ليستبوكس تحياتي يرجى تعديل كود الحذف والتعديل (1).xlsm

1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً) مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات) 2- للبحث عن اي فاتورة اكتب رقمها ثم اضغط Enter ( يتم تحديد ما تبحث عنه باللون الأصفر في الشبت) أو ( قم بتجديدها من الــ List Box ) 3- لحذف اي فاتورة اكتب رقمها ثم اضغط الزر حذف أو ( قم بتجديدها من الــ List Box ) ثم اضغط الزر حذف الاكواد المطلوبة Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete UserForm_Initialize For Each itm In Arr_text Me.Controls(itm) = "" Next Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Fnd_AfterUpdate() Debut If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1) If F Is Nothing Then MsgBox "This Item: " & """" & Me.Fnd & """" & Chr(10) & _ "Not Exists In Column (A)" Exit Sub End If K = F.Row For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next sh.Cells(K, 1).Offset(1).Select sh.Cells(K, 1).Resize(, 7).Interior.ColorIndex = 6 End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub Fnd = ListBox1.List(ListBox1.ListIndex, 0) Fnd_AfterUpdate End Sub '++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف مرفق My_ListBox.xlsm

جزاك الله خيرا

استاذ صالح جرب برنامج hex editor سمعت أنه ممكن يفتح برامج الاكسيس عن طريق اتغير dbp الى dox وتغيير اسم الملف ثم افتحه من الاكسيس وبعدين افتح الريبون والشيفت هذا الشرح منقول مع مخترق اخترق أحد برامجي بصيغة accde ووصول الاكواد والنماذج وارسلها لي .. لعله يفيدك في شئ تحياتي 🌹

وعليكم السلام 🙂 لا اعرف ولم اسمع بأنه يمكن استخراج الكود من الملفات صيغ mde و accde ، غير موقع واحد من احد مبرمجي الاكسس المحترفين اصحاب ثقة ، يمكنك رفع ملفك الى الموقع التالي: MDE to MDB Conversion - Retrieve VBA code from your MDE/ADE Databases (everythingaccess.com) وعليه اذا كان فيه امكانية لإسترجاع برنامجك الى صيغة accdb ، فالموقع سيثبت لك ذلك (عن طريق الايميل وبعد يوم او اكثر) ، وفي مقابل مبلغ من المال (يبدأ بمبلغ 450 دولار) ، وبعد التأكد بأنك صاحب البرنامج حقا ، سيعملون المطلوب ويرجعون لك البرنامج بصيغة accdb ويمكنك التعديل عليه 🙂 واذا اتخذت هذا الطريق ، فياريت تكتب لنا هنا مؤكدا ما جرى 🙂 جعفر

انسخ الكود في مشاركتي السابقة ثم الصقه داخل الفورم لا اكثر ولا اقل عندي شغال 100/100

ضع الكود لي في زر تشغيل الصوت في حدث الفورم Private Sub UserForm_Initialize() WindowsMediaPlayer1.URL = ThisWorkbook.Path & "\20.MP3" WindowsMediaPlayer1.Controls.Play End Sub

ضع هذا الشيء في الخلية g7 واسحب نزولا =if(K7;K7;"") و نفس الشيء في c7

اتمنى يكون المطلوب تنبه بوجود مسبق.accdb

اذا كان تم تم المطلوب اضغط افضل اجابة لاغلاقه ولا تنس الضغط على اعجاب ايضاً

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

تفضل با ضديقي TQTHAMI و عيد سعيد TQTHAMI.xlsm

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير مثال رائع وحله من استاذ رائع ولي طلب اذا امكن ابي نفس الملف ولكن بدون حذف الحروف المكرره مثال طلال ط ل ا ل كل حرف في حقل ts.xlsm

تفضل هذا التعديل empoyee - Copie (1) (1).accdb

تفضل اخي الكريم empoyee - Copie (1).accdb

السلام عليكم جميعا... الحمدلله تم انتهائى من تصميم برنامج الاقساط هذا واللذى يقوم بمراقبة وسداد الاقساط ونبذة عن البرنامج هو مجانى بداية ثم يحتوى هذا البرنامج على فورم دخول بكلمة مرور وهى (12345) ويحتوى على عدة صفحات منها الرئيسية ومنها العملاء ليتم تسجيل بيانات العملاء فيها ومنها حالة العملاء وهى صفحة يتم مراقبة حالة السداد للعملاء ولكن الحالات هى اوشك اى على السداد اذا مر27يوم من تاريخ اخر سداد للعميل ومتاخر اذا مر اكثر من30يوم ومتاخر جدا اذا مر اكثر من 62يوم وغيرذلك ومن هذه الصفحات البحث والترحيل وفيها تقوم بالبحث عن العميل باى حرف من اسمه او من السلعة المباعة له او عنوانه او ان كان ضامن له ويتم السداد هناك و تستطيع تغيير القيمة الافتراضية للقسط الشهرى يدوى ويتم الاحتساب على ذلك ومنها صفحة عمليات السداد التى قام العميل بتسديدها وتستطيع التعديل فى اى بيانات فهى قابلة للتعديل صفحة استعلام مختصر وتكون ب البحث بالكود يتم جلب كل عمليات العميل اول حسابه والمتفق عليه والمسدد ومتى ينتهى حسابه وكم سدد والقيمة المسددة والمتبقية وهى غير قابلة للتعديل ومن هذه الصفحات صفحتين فارغتين ليقوم المستخدم باستخدامهما كيف يشاء ومنها صفحة كلمات المرور والصلاحيات وهذه تقوم بالتعديل على كلمات المرور واعطاء صلاحيات الدخول لكل مستخدم وتم تحديد ثلاثة اشخاص المدير و2موظف وهناك تستطيع ان تكتب اسم المنشأة ليظهر بالرئيسية وايضا اسم المستخدم يظهر بالرئيسية واسم المدير وفى صفحة كلمات المرور تقارير بسيطة وايضا فيها تم ذكر بعض المقربين الى قلبى من الاساتذة الافاضل بروابط صفحات الفيس الخاصة بهم فهم اصحاب الفضل على من بعد الله... هذا والحمدلله واخيرا الدال على الخير كفاعله انشر الخير يمكن غيرك محتاج ولا تدرى ولا أسالكم الا الدعاء فى ظهر الغيب وعذرا على الاطالة والسلام عليكم ورحمة الله وبركاته برنامج الأول للاقساط...عمر جاد ابونصار.xlsb.zip عذرا على الاطالة لكن بينت فيها كيفية العمل على البرنامج حتى لا اجهد المستخدم

تفضل ضع المؤشر داخل السجل الذي تريد تكراره ثم انقر الزر نسخ مجموعة سجلات2.rar

تفضل اخى الكريم برنامج حسابات صغير يعتمد على قيود اليوميه من تصميمى ما عليك الا انك تنشء حساب باسم الصندوق واسماء العملاء الذى تريد وتعامل معها بحكم خبرتك فى المحاسبة مدين ودائن وكدا اسم المستخدم admin ;كلمة السر admin برنامج حسابات يعتمد على قيود يوميه.rar