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

امر اخير لماذا تتعب نفسك بكتابة اسماء التقارير في الليست بوكس وكلما اضفت تقرير تقوم باضافة اسمه بينما ممكن جعل مصدر الليست SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Type)=-32764)); وهنا تجد ان اي تقرير تعمله تجد اسمه موجود تلقائي Listbox.accdb

مسودة الاجازات.xlsmأنا أضفت لك الكود فى الملف جرب الكود شوف قائمة التشغيل دى أو بدايتها عشان تعرف فين الكود بيتكتب

عليكم السلام شغلة عالسريع لوكم ارجاء التأكد من الترقيم في جميع الصفحات Sub test() Dim a Dim i&, nn&, x& Dim myArea As Range With Sheets("الرئيسية اول") a = Range(.Cells(6, 2), .Cells(6, 2).End(xlDown)).Cells nn = .Cells(2, 7) End With For i = 2 To Sheets.Count - 1 With Sheets(i) x = 1 For Each myArea In .Columns(1).SpecialCells(2, 1).Areas myArea.Offset(, 2).Resize(nn).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + nn - 1 & ")"), [{1}]), "") x = x + nn Next End With Next End Sub

جرب في زر الامر اكتب Dim k As Variant Dim r As String For Each k In Me.List2.ItemsSelected r = Me.List2.ItemData(k) DoCmd.OpenReport r, acViewPreview Next k الملف مرفق Listbox.accdb

حضرتك لا يوجد في الملف الرقم 12 لكي يتم تغييره المكتوب 12.5 القيمة الصغرى والكود لا يعتمد على قيم ثابته فالكود يعمل بحسب القيم المدخلة في الخلية C5 , D5 , E5 وإليك شرح الكود Sub replace() 'يتم مقارنة اذا كانت القيمة الجديدة أكبر من القيمة القديمة If [e5] > [d5] Then 'اوجد رقم اخر صف يحتوي على بيانات lr = [B10000].End(xlUp).Row ' عمل حلقة تكرارية بدايتها رقم أول عمود ونهايتها اخر اعمود For y = 2 To 9 ' يختبر مكان وجود المادة If Cells(8, y).Value = [c5] Then 'حلقة تكرارية اخرى بدايتها أول صف يحتوي على بيانات ونهايتها اخر صف For x = 9 To lr 'يحدد أين تقع القيمة المراد استبدالها (القيمة القديمة ) If Cells(x, y).Value = [d5] Then 'يستبدل القيمة التي عثر عليها بالقيمة الجديدة Cells(x, y).Value = [e5] End If Next End If Next End If End Sub وكما تلاحظ في الشرح لم يتم الربط بقيم ثابته

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

ربما لم تسمع المنصة لا تنفذ مشاريع باسمها وانما هي وسيلة رسمية لجمع التبرعات و تتبع مركز الملك سلمان للإغاثة والأعمال الإنسانية ومجموع التبرعات لمنكوبي الزلزال حتى هذه الدقيقة 367,696,355 ريال وتم جمعها من 1,647,788 متبرع ولو حبيت تتطلع على اعمال المركز والمشاريع المنفذه شاهد هنا اللهم اجعل عملنا خالصا لوجهك الكريم

السلام عليكم ورحمه الله وبركاته جرب هذا الكود يقوم بحذف الخلايا الفارغه لعله يفيدك Sub DeleteRows() Dim LastRow As Long Dim i As Long LastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = LastRow To 1 Step -1 If Cells(i, 1) = "" Then Rows(i).Delete End If Next End Sub

اذا اردت تشفير قاعدة البيانات بتحويلها من Accdb الى Accde لابد من عمل قاعدتان امامية واخرى خلفية طبعا قاعدة البيانات الخلفية والخاصة بالجداول لابد ان تكون غير مشفرة اى Accdb اما الامامية ان اردت تشفيرها الى Accde لابد من عمل ذلك مرتين 1- على جهاز يحتوى على اوفيس 32 بيت 2- على جهاز يحتوى على اوفيس 64 بيت وتعطى للعميل مع قاعدة الجداول الخلفية القاعدتان الاماميتان والمشفرتان الـقاعـدة الامامية ذات النواة 32x المشفرة ذات الامتداد Accde والقاعدة الامامية ذات النواة 64x المشفرة ذات الامتداد Accde حتى يستخدم القاعدة الامامية التى تتوافق مع نواة الاوفيس لديه او اذا قام العميل فى احد الايام بتغيير الاوفيس بإصدار آخر ونواة مختلفة يعمل بالقاعدة الاخرى او اذا كان العميل يملك اكثر من جهاز وقد تختلف انوية اصدارات الاوفيس من جهاز لاخر

السلام عليكم ورحمة الله تعالى وبركاته على كل مصممى ومطورى قواعد البيانات ببساطة عند محاولة تشفير قاعدة البيانات الى accDE لابد من إنشاؤها مره باستخدام office (Access) x64 و إنشاؤها مره أخرى باستخدام office (Access) x32 حتى لا تحدث مشكلة عند العملاء بسبب إختلاف أنوية الأوفيس للاسف الشديد . للعلم الموضوع مختص فقط بتشفير القاعدة بالامتداد Accde فقط اى أنه لا علاقة للموضوع بالامتداد Accdb ولا علاقة للموضوع باستخدام دوال API حتى لو تم الاخذ فى الاعتبار عند كتابة الكود مراعاة عمل الكود عند استخدام دوال API على كلتا النواتان 64x , 32 x هذه لقطة من مقال المصدر : >>--> مايكروسوفت لذلك فإن accDE الخاص بـ x32 accDE و x64 خاصان جدًا بحجم النواه والبنية التي تم تجميعهما بها ويجب أن تعمل الأجهزة المستهدفة بنفس حجم النواة لاستعمال accDE الذي تم إنشاؤه باستخدامه ولا توجد استثناءات لهذه القاعدة

بعد اذنك أخي متقاعد ممكن أضيف زر تحديد وزر عدم تحديد الكل . Listbox-D11.accdb

ابحث عن هذه المكتبة Microsoft WMI Scripting v2.1 library ضمن مكتبات الاكسس وعلم عليها فقط

طريقة اخرى باستخدام for next Dim k As String Dim i As Integer For i = 0 To List2.ListCount - 1 If List2.Selected(i) = True Then k = List2.Column(0, i) DoCmd.OpenReport k, acViewPreview End If Next i الملف مرفق Listbox.accdb

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

اخي طارق نادر جرب المرفق تحويل معادلة إلى كود.xlsm

Try this code Private f As Boolean Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) PopulateComboBox Me.ComboBox1 End Sub Private Sub UserForm_Initialize() f = False Me.ComboBox1.MatchEntry = fmMatchEntryNone PopulateComboBox Me.ComboBox1 End Sub Sub PopulateComboBox(ByVal cmb As MSForms.ComboBox) Dim arrIn, arrOut(), i As Long, j As Long With Sheets(1) arrIn = .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Value End With ReDim arrOut(1 To UBound(arrIn)) For i = 1 To UBound(arrIn) If arrIn(i, 1) Like "*" & cmb.Text & "*" Then j = j + 1 arrOut(j) = arrIn(i, 1) End If Next i If j = 0 Then cmb.Clear: Exit Sub ReDim Preserve arrOut(1 To j) With cmb .Clear .List = arrOut If j > 0 And f Then .DropDown Else f = True End With End Sub

وكيف يتم تحويل قاعدة البيانات الي accde او mde اخي الحبيب

وعليكم السلام ورحمة الله وبركاته اخى @طارق نادر هل اطلعت على الموضوع المشار في مشاركه اخى @كريم نظيم قبل ان تقوم برفع الموضوع؟

والله نجحت فى تعديل على الكود ليتماشى مع ملفك ويكون شيت الورد مفتوح الترحيل من الاكسيل الى الورد.rar

السلام عليكم ورحمة الله وبركاته اسعد الله اوقاتكم جميعا يؤسفني ان أقول لك وانا سوري اسكن في هاتاي وعملت في جمعية كمدير مالي لمدة سنتين ، المنظمة تعمل في ادلب والادارة في تركيا في هاتاي يؤسفني كل الاسف ان اقول لك انني لم اسمع بمنصة ساهم ابدا اثناء عملنا الاغاثي ابدا وسأتحقق من اصدقائي في العمل

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

وعليكم السلام هذي مشاركه بعد اذن الاساتذة الخانة الاولى التاريخ كما هو ( 2023/2/14 ) ضع في تنسيق الحقل yyyy/mm/dd الخانه الثانية ( فبراير ) ضع في تنسيق الحقل mmmm الخانة الثالثه ( 2023 ) ضع في تنسيق الحقل YYYY مرفق مثال تفقيط هجري وميلادي تفقيط التاريخ الميلادي والهجري.rar

مشاركة مع استاذي أستاذ موسى تفضل أخي كل شيء طلبته وباستعلام بسيط ..... افتح الفورم وطالع النتيجة . DTest114.accdb

وعليكم السلام ورحمة الله وبركاته 🙂 هذه دالة تحول التاريخ إلى نص .. ويمكنك تعديلها حسب ما تريد .. Public Function DateAsText(GivenDate As Date) As String Dim Daytxt, Monthtxt, Yeartxt As String Daytxt = NoToTxt(Day(GivenDate), "", "") 'Monthtxt = "من شهر " & NoToTxt(Month(GivenDate), "", "") ' فعل هذا السطر إذا أردت كتابة الشهر بالرقم وليس بالاسم Monthtxt = "من شهر " & MonthName(Month(GivenDate)) Yeartxt = "سنة" & NoToTxt(Year(GivenDate), "", "") DateAsText = Daytxt & "" & Monthtxt & " " & Yeartxt & "ميلادي" End Function Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim MyNo As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then MyNo = Mid$(GetNo, i + 1, 3) Else MyNo = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(MyNo, 1, 3)) > 0 Then RdNo = Mid$(MyNo, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(MyNo, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(MyNo, 2, 1) My10 = MyArry2(RdNo) If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function وطريقة الاستخدام موضحة في المرفق : تفقيط التواريخ.accdb

يا أخي طبق ما أرسلته............... الله يرحم والديك

هذا مثال ..وبصراحة لم افهم قصدكم مع الاستاذ الحلبي isDate.rar

بالنسبة لنا في السعودية يوجد اكثر من قناة لتوصيل التبرعات ومن اهمها وآمنها في وصول التبرعات الى مستحقيها وهي منصة ساهم التابعة لمركز الملك سلمان للإغاثة والأعمال الإنسانية . مركز الملك سلمان للإغاثة ///// التبرع لمساعدة ضحايا الزلزال في سوريا وتركيا من خلال #منصة_ساهم عبر الرابط الآتي: https://sahem.ksrelief.org/SYTR

السلام عليكم اذا كان القصد السماح المستخدم على ادخال تاريخ فقط في حقل نصي تفضل انظر للملف المرفق تحياتي test.accdb

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

جزاكم الله خيرا 🌹 لم اقم بحفظ اسم الملف نظرا لان الكود القديم كان يقوم بعمل حفظ للمرفق برقم ال ID لذلك لم تستدعى الحاجه لإضافة بيانات وحقل بلا داعى 😉

يمكن عمل ذلك من خلال خاصية البحث ولاستبدال بتحديد العمود المراد البحث فيه واستبدال القيمة وإليك كود يقوم بتنفيذ المطلوب ( مع ملاحظة انه يمكن اختصار الكود لكن فضلت ان يكون هناك شروط قبل التنفيذ ) Sub replace() If [e5] > [d5] Then lr = [B10000].End(xlUp).Row For y = 2 To 9 If Cells(8, y).Value = [c5] Then For x = 9 To lr If Cells(x, y).Value = [d5] Then Cells(x, y).Value = [e5] End If Next End If Next End If End Sub

تفضل جرب اخي اسم المستخدم: admin كلمة المرور : 12345 Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheet1 Dim lr As Long lr = sh.Range("A" & Rows.Count).End(xlUp).Row '''''''''''''''Validation''''''''' With sh .Cells(lr + 1, "A").Value = Me.TextBox2.Text .Cells(lr + 1, "B").Value = Me.TextBox3.Text .Cells(lr + 1, "C").Value = Me.TextBox4.Text .Cells(lr + 1, "D").Value = Me.TextBox5.Text .Cells(lr + 1, "E").Value = Me.TextBox6.Text .Cells(lr + 1, "F").Value = Me.TextBox7.Text .Cells(lr + 1, "G").Value = Me.TextBox8.Text .Cells(lr + 1, "H").Value = Me.TextBox9.Text .Cells(lr + 1, "i").Value = Me.TextBox10.Text .Cells(lr + 1, "j").Value = Me.TextBox11.Text .Cells(lr + 1, "k").Value = Me.TextBox12.Text End With For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i ListBox1.ColumnCount = 11 ListBox1.RowSource = "A1:K100000" MsgBox "تمت اضافة البيانات بنجاح" End Sub قاعدة بيانات1.xlsm

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

قبل ان تفكر فى موضوع التحويل لابد من استيعاب الاتى :- اذا اردت تشفير قاعدة البيانات بتحويلها من Accdb الى Accde لابد من عمل قاعدتان امامية واخرى خلفية طبعا قاعدة البيانات الخلفية والخاصة بالجداول لابد ان تكون غير مشفرة اى Accdb اما الامامية ان اردت تشفيرها الى Accde لابد من عمل ذلك مرتين 1- على جهاز يحتوى على اوفيس 32 بيت 2- على جهاز يحتوى على اوفيس 64 بيت وتعطى للعميل مع قاعدة الجداول الخلفية القاعدتان الاماميتان والمشفرتان الـقاعـدة الامامية ذات النواة 32x المشفرة ذات الامتداد Accde والقاعدة الامامية ذات النواة 64x المشفرة ذات الامتداد Accde حتى يستخدم القاعدة الامامية التى تتوافق مع نواة الاوفيس لديه او اذا قام العميل فى احد الايام بتغيير الاوفيس بإصدار آخر ونواة مختلفة يعمل بالقاعدة الاخرى او اذا كان العميل يملك اكثر من جهاز وقد تختلف انوية اصدارات الاوفيس من جهاز لاخر لأن accDE الذى تم تجميعه فى بيئة النواة 64x لن يعمل الا فى نفسة البيئه على اوفيس 64x و الـ accDE الذى تم تجميعه فى بيئة النواة 32x لن يعمل الا فى نفسة البيئه على اوفيس 32x فكما لاحظتم ان مرفق الاستاذ @ابوخليل والذى تم تجميعة فى بيئة النواة 32x لم يعمل على الاجهزة التى تحتوى على اوفيس 64x الا اللهم انك ان اردت عمل ذلك لابد ان تقوم بتجميع الملف الخاص بقاعدة النماذج (القاعدة الامامية) على جهازين محتلفين احدهما به اوفيس 64x والاخر به اوفيس 32x