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

من خلال نموذج الادخال في حدث عند عدم الوجود في القائمة ضع الكود التالي لاخينا الاستاذ @ابوآمنة Dim strSQL As String, X As Integer X = MsgBox("هذة المدينة ليست من ضمن القائمة .. هل ترغب في إضافتها؟", vbYesNo + vbDefaultButton1) If X = vbYes Then strSQL = "Insert Into tbl_city (city) values ('" & NewData & "')" CurrentDb.Execute strSQL Response = acDataErrAdded Else Response = acDataErrContinue End If عدلت اسم جدول اسماء المدن واسم المدينة الى الانجليزي الاسم العربية مع اعتزازنا وحبنا للغتنا الا انها تسبب اشكال مع محرر الاكواد الملف مرفق Database2111.accdb

وعليكم السلام -على الرغم انك لم تقم برفع ملف موضح فيه كل المطلوب الا انك يمكنك استخدام هذا Public Function XLookup(ByVal vTable As Variant, _ ByVal vResult As Variant, _ ParamArray vKeyVals() As Variant) As Variant Const cRoutine As String = "XLookup" Dim oLo As ListObject 'Table containing data Dim vKeys As Variant 'vKeyVals internal version Dim sCol As String 'Column Address Range to search Dim vKey As Variant 'Key(s) to find in Column(s) Dim lKey As Long 'Current key Dim lRow As Long 'Found Row Dim lCol As Long 'Found Column Dim sAddTxt As String 'Additional Error Text ' Error Handling Initialization On Error GoTo ErrHandler Set XLookup = Nothing ' Check Inputs and Requisites ' Table Select Case TypeName(vTable) Case Is = "ListObject": Set oLo = vTable Case Is = "Range": Set oLo = vTable.ListObject Case Else: Set oLo = ActiveSheet.Evaluate(vTable).ListObject End Select ' Return Column If TypeName(vResult) = "Range" Then vResult = vResult.Value2 ' Search Keys If UBound(vKeyVals) = -1 Then Err.Raise DspError, , "#Key(s) required" ' When called by VBA, ParamArrays sometimes are stuffed in the first element If IsArray(vKeyVals(LBound(vKeyVals))) Then _ vKeys = vKeyVals(LBound(vKeyVals)) Else _ vKeys = vKeyVals ' Procedure With oLo If Not .DataBodyRange Is Nothing Then ' Just 1 key - Use Worksheet.Function because it is fastest w/1 Key If LBound(vKeys) = UBound(vKeys) Then vKey = vKeys(UBound(vKeys)) If IsNumeric(vKey) Then vKey = CDbl(vKey) lRow = Application.WorksheetFunction.Match( _ vKey, _ .ListColumns(1).DataBodyRange, _ 0) ' More than 1 key - Use Worksheet.Evaluation because it is fastest w/multiple keys Else ' Concatenate Key Values and Search Column Addresses For lKey = LBound(vKeys) To UBound(vKeys) lCol = lCol + 1 sCol = IIf(sCol <> vbNullString, sCol & " & ", vbNullString) & _ .ListColumns(lCol).DataBodyRange.Address ' Determine Key Value If TypeName(vKeys(lKey)) = "Range" Then _ vKey = vKey & vKeys(lKey).Value2 Else _ If IsDate(vKeys(lKey)) Then _ vKey = vKey & CLng(vKeys(lKey)) Else _ vKey = vKey & vKeys(lKey) Next ' Find Row # by Evaluating MATCH within the Table's worksheet lRow = .Parent.Evaluate("=Match(""" & vKey & """," & sCol & ",0)") End If ' Get Column # lCol = .ListColumns(vResult).Index ' Return result Set XLookup = .ListRows(lRow).Range(lCol) End If End With ErrHandler: If Err.Number > 0 Then ' Create sAddTxt (Additional Error Text) if needed Select Case Err.Number Case Is = 9: sAddTxt = "Column " & vResult & " not found in " & oLo.Name Case Is = 13, 1004: sAddTxt = "Key(s) " & Join(vKeys, ",") & " not found" Case Is = 424: sAddTxt = "Table not found" End Select ' Customize Errors based on UDF of VBA caller If TypeName(Application.Caller) = "Range" Then 'Called from UDF MLookup = CVErr(xlErrRef) Debug.Print cRoutine & ":" & Err.Description & vbLf & sAddTxt Else 'Called from VBA (most likely) Select Case Err.Number Case Is = 13, 1004: 'Key(s) not found. Log Error Debug.Print cRoutine & Err.Description & vbLf & sAddTxt Case Else: 'Pop Up Error Message Select Case DspErrMsg(cModule & "." & cRoutine, sAddTxt) Case Is = vbAbort: Stop: Resume 'Debug mode - Trace Case Is = vbRetry: Resume 'Try again Case Is = vbIgnore: 'End routine End Select End Select End If End If End Function أو يمكنك مشاهدة هذا الرابط Custom Excel XLOOKUP Function أو هذا الرابط UDF: XLOOKUP – Using VLOOKUP for left AND right searches وهذا ايضا فيديو للشرح https://www.youtube.com/watch?v=Tbqh4_HcUlI

وانا اتفق معاك 🙂 جعفر

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

في الواقع ردي انا واخي اشرف متشابهين ، ولكن مختلفين 🙂 طريقتي هي عمل التنسيق في الجدول ، مما يعني ، ان اي استعلام او نموذج او تقرير جديد ، سيأخذ هذا التنسيق من الجدول مباشرة ، وسيُظهر 9 خانات + خانة الصفر اللي على اليسار ، ولكن وكما قلت ، في واقع الامر ، البرنامج يرى 9 خانات فقط. بينما طريقة اخي اشرف ، فيجب ان نضع هذا التنسيق في النموذج ثم في التقرير "يدويا" ، وسيُظهر 9 خانات + خانة الصفر اللي على اليسار ، ولكن في الجدول سيرى 9 خانات فقط. لكل طريقة ميزاتها وعيوبها ، وهنا يجب ان نعطي المستخدم طريقة لا يتلخبط بها 🙂 جعفر

بعد اذن استاد حسين تفضلي اخت زهرة هذا بالمعادلة في العمود b تستطيعين سحب المعادلة الى اي مدى تريدينه وتقومين بكتابة الرقم في العمود a وستعمل المعادلة =IF(A2<>"";"basic";IFERROR(IF(OFFSET(B2;-1;0)<>"";IF(ROW()-LOOKUP(2;1/(A$1:A2<>"");ROW(A$1:A2))>LOOKUP(2;1/(A$1:A2);A$1:A2)-1;"";"sub");"");"")) 99999999999999999999999999999999999 (1).xlsm

هلا اخيTEST.mdb جرب المرفق

اخي الفاضل zoom10 بعد اذن الاساتذة من غير ما نغير اي حاجة في الجدول اللي انت عامله جميل رقم الموبايل زي ما هو رقم صحيح طويل كل اللي هتعمله روح للنموذج في وضع التصميم وفي خانة رقم الموبايل في التنسيق ضع 0000000000 مثل الصورة هتلاقي الصفر ظهر تمام التمام من غير ما نعيد حاجة او نغير في الجدول ولما نكتب في الجدول جديد نكتب عادي 10 ارقام اولها الصفر وكله هيبقي تمام 222.accdb

السلام عليكم 🙂 اذا كان هذا الحقل دائما بحاجة الى صفر على يسار الارقام ، فيمكن ان : 1. في الجدول ، نجعل نوع هذا الحقل "رقم" طويل ، 2. في التنسيق ، تضع اصفار بالعدد الذي تريد "مع الصفر على اليسار" ، فإذا تريد 10 ارقام ، يكون التنسيق: 0000000000 3. الآن ، لما تُدخل الارقام (سواء في الجدول او الاستعلام او النموذج او الكود) ، لا تُدخل الصفر على اليسار ، وانما ادخل التسعة ارقام ، مثل : 503052054 والبرنامج سيُظهر لك : 0503052054 4. ولكن يجب عليك الانتباه ، ان هذا مجرد تنسيق ، والرقم الحقيقي المحفوظ في البرنامج هو التسعة ارقام ، والبرنامج ما يشوف غير هذه التسع ارقام ، لهذا السبب فالصفر الاخير لا وجود له إلا في عرض/اظهار الرقم 🙂 جعفر

برنامج يصلح لادارة عيادات الاسنان والعلاج الطبعى بسيط وسهل الاستخدام بدون باسورد طبيب الاسنان او العلاج الطبيعى.xlsm

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

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

السلام عليكم ورحمة الله وبركاته هذا الدرس تم شرحه في فيديو لي علي اليوتيوب تقريبا من شهر يونيو 2019

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

تفضلي 99999999999999999999999999999999999.xlsm وهذا من 5 الى 2 99999999999999999999999999999999999.xlsm

بعد اذن استاد حسين قم بتغيير هذا السطر من Set ws = Workbooks("دمج الملفات").Worksheets("ورقة1") الى Set ws = Workbooks("دمج الملفات.xlsm").Worksheets("ورقة1")

اخي الكريم لديك امتداد الملفات المخزنة في المجلد هو :xlsm وفي الكود xlsx اخل الى الكود وحول الامتداد من File = Dir(Path & "*.xlsx*") الى File = Dir(Path & "*.xlsm*") وسيعمل بحول الله وقوته

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

جرب استخدم أداة Disk cleanupd جرب أيضا. افراغ الكاش و قد يكون هناك خطأ في البرمجة لدي لحفظ قيم كثيرة في الذاكرة RAM وبالتالي استهلاكها

1- قم بتحويل الحقل الى نص 2 - فى الاستعلام قمت باضافة الصفر 3 - انسخ حقل الاضافة الى الحقل الاصلى 222.rar

اذن يترتب علي إعادة كتابة الصفر لـــ600 مشترك 😵

نعم كل شي ممكن في اكسس نستبدل الكود السابق بكود فلترة لحقلين Dim k As String Dim x As String k = "taxt_name1 like '*" & city & "*'" x = "[year_1] like '*" & cmbLocation & "*'" Me.frmOrder.Form.Filter = k & " and " & x Me.frmOrder.Form.FilterOn = True بالامكان الفلترة بالعام فقط او بالمدينة فقط او الفلترة بالحقلين الملف مرفق مع رجاء التقيد بتعليمات الموقع سؤال واحد حتى مايزعلوا علينا المشرفين ويغلقوا المشاركة عمل الفراز(1).accdb

انظر المرفق الأول باستخدام زر الفرز .. والمرفق الثاني بدون استخدام زر الفرز .. أرجو أن يكون المطلوب عمل الفراز.accdb عمل الفراز (1).accdb

جزاك الله خيرا وتقبل منا ومنكم

يا أخ سامر : فرجيني حقل اسم الطبيب في الجدول .. أين هو وكذلك التخصص .. لازم تضيف حقل خاص بهم . أنا ما فهمت اسم الطبيب ثابت والتخصص .. وهم غير مضافين في الجدول من الأساس

اخت زهرة ضعي هذا الكود في حدث textbox1 واتبعي نفس خطوات الشرح في الصورة Private Sub TextBox1_Change() If Len(Dir(ThisWorkbook.Path & "\" & TextBox1.Value & ".jpg")) > 0 Then Image1.Picture = LoadPicture(ThisWorkbook.Path & "\" & TextBox1.Value & ".jpg") Else Image1.Picture = LoadPicture("") End If End Sub

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

جرب هذا طبعا بعد اذن الأستاذ الرائد , فممكن ان تكون هذه مشكلة من عندك فملف الأستاذ الرائد يعمل بكفاءة عموماً -تفضل تم التعديل على نفس اكوادك شششششش1.xlsm

رائع استاذنا الفاضل ولكن عند فتح النموذج تكون النتيجة Record 1 Of 1 Records مهما كان عدد السجلات وبعد التنقل للسجل التالي يعطي النتيجة الصحيحة وبعد اضافة Me.RecordsetClone.MoveLast قبل الكود تكون النتيجة Record 1 Of 4 Records مطابق للعدد الكلي للسجلات

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

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

السلام عليكم 🙂 ولإثراء موضوع : طلب كود ايقاف حدث فالامر الاقوى والمسيطر والذي يوقف الكود بغض النظر ، هو End 🙂 تقدر تنظر له انه فرملة احتياطية للوقوف الإضطراري ، او موت فُجائيّ للكود ، لأن الكود يتوقف عند الامر ولا ينتقل بعدها للسطر التالي 🙂 وطول سنوات برمجتي ، استعملته مرة واحدة فقط ، في برامج متشعب جدا ، لم اُحسن قفل بعض Objects ، ولم اعرف ايهم بسبب استعجالي ، فاستعملت الامر End وخلص الموضوع (طبعا بعديت اصلحت الكود وازلت الامر) 🙂 رجاء ، لا تستعملوه للبرمجة العادية ، وإنما فقط للحالات الخاصة والمستعصية 🙂 جعفر

شوفالصورة من نموذجك فقط اعد ادخال الرقم

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

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

اختي الكريمة تفضلي لقد قمت باضافة زر تعديل بدل بحث وتعديل من جعلهم زر واحد في اليوزرفورم 2.xlsm

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

السلام عليكم جميعا اليكم كيفية انشاء نسخة احتياطية من اي ملف اكسيل مربوط بالملف الاصلي عن طريق كود في الفيجوال بيسك في فولدر محدد . شرح مميز للكود ===================================================== رابط تحميل الكود جاهز https://www.file-upload.com/c60bffhuli9q لمشاهدة الفيديو https://www.youtube.com/watch?v=lYS5tHxKsGY

بعد اذن الاخ شوقي هذا الكود ربما يفي بالغرض Option Base 1 Sub get_me_Markaz() Dim x, Last_Row As Integer Dim arr() x = 0 With Sheets("البيانات") Last_Row = .Cells(Rows.Count, "d").End(3).Row For i = 3 To Last_Row If Application.CountIf(.Range("d3:d" & i), .Range("d" & i)) = 1 Then x = x + 1 ReDim Preserve arr(1 To x) arr(x) = .Range("d" & i) End If Next End With For k = LBound(arr) To UBound(arr) On Error Resume Next If Len(Sheets(arr(k)).Name) = 0 Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = arr(k) End If On Error GoTo 0 Next Erase arr Sheets("البيانات").Select End Sub

بعد إذن أساتذتى وعمالقة هذا الصرح الحل بالمعادلة أسهل حسابات2.rar