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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكنها بالحديثة و بطريقة فوكشية ▫▪◽◾◻◼. الكثير من المواضيع التي تحدثت عن كيفية رفع ملفات المستخدم على جوجل درايف أو غيره من المواقع التي تقدم مساحات سحابية متعددة الخدمات لمستخدميها .. اليوم وبتوفيق من الله ، تم إنشاء هذه الأداة للتعامل مع جوجل درايف Google Driveحصراً ، لكونه يقدم مساحة 15 جيجا بايت لمستخدميه . ما كان يؤرق الكثيرين هو أن جوجل أو غيره من مقدمي الخدمة المشابهة يقوم بتعديل سياسته وقوانينه كل فترة . لكن هنا وبهذه الأداة المجانية تم حل المشكلة بعد فحصها مراراً وتكراراً (متمنياً ذلك) . الفكرة في الأداة تعتمد على حساب جوجل أو Gmail شخصي . ما يلزم المستخدم هنا تطبيق الخطوات البسيطة التالية حسب الصور أو الفيديو في هذا الرابط . 📌 عند فتح الأداة لأول مرة ، سيساعدك معالج الإنشاء بجميع الخطوات ( خطوة بخطوة ) وستظهر لك هذه الرسالة :- 📌 عند النقر على Yes ، ستظهر لك رسالة الإرشاد الأولى كالتالي :- 📌 سيتم فتح المتصفح لديك على الرابط الخاص بإنشاء الخدمة .. وللمتابعة دون الإطالة ، أترككم مع الصور و الخطوات خطوة بخطوة . 📌 عند الإنتهاء من تنفيذ الخطوات والحصول على رمزي الـ ( CLIENT ID و CLIENT SECRET ) . ✨ سيتوجه بك معالج الإنشاء للخطوة قبل الأخيرة كالآتي :- 📌 هنا يطلب منك لصق رمز CLIENT ID الذي حصلت عليه من تسلسل الخطوات السابقة . ثم بعد لصقه والضغط على OK ، ستظهر لك الرسالة التالية :- 📌 والتي يطلب منك لصق CLIENT SECRET كما في الصورة أعلاه . ✨ الآن الخطوة الهامة والتلقائية ، وبعد لصق الرمزين الخاصين بحسابك في جوجل درايف ( لا تقم بمشاركتهم مع أي أحد ) ، سنهب للحصول على رمز التفويض مرة واحدة فقط ! وهذا يعني أنك لن تحتاج إليه مستقبلاً . انظر الصورة التالية :- 📌 عند النقر على موافق ، سيتم فتح متصفحك على رابط خاص في جوجل لتمنح بريدك الإلكتروني الذي استخدمته في إنشاء الخدمة سابقاً كامل الصلاحية لإستخدام خدمات جوجل درايف . وطبعاً بالمتابعة وتأكيد الموافقة ، ستحصل على رمز التفويض الخاص بك و لمرة واحدة فقط ولن تحتاجه فيما بعد ، فتقوم بنسخه ولصقه في رسالة التأكيد التالية :- الآن وبفضل الله ، ستظهر لك رسالة " تم التفويض بنجاح" ، وبهذه الخطوة تم ربط آكسيس بحساب جوجل درايف الخاص بك ، وستظهر لك واجهة الأداة كما في الصورة أدناه . وما يلي شرحاً سريعاً لمميزاتها . مميزات الأداة :- تتيح لك الأداة رفع الملفات بأي امتداد وبأي حجم ؛ إلى أي مجلد تحدده في حسابك على جوجل درايف ، أو في الملف الرئيسي عند عدم اختيارك لمجلد محدد . والمجلدات التي في حسابك ستظهر لك عند النقر على زر "مجلداتي" ، ثم من قائمة الكومبوبوكس ستختار المجلد الهدف لرفع الملف اليه . زر "إختيار ملف" لإختيار الملف الذي ترغب برفعه على جوجل درايف . زر "معاينة" مخصص لمعاينة الملف حسب الرسالة التي ستظهر لك . زر "مسح الحقول" لتفريغ العناصر من قيمها . زر "ارفع الملف" والذي من خلاله ستقوم بتنفيذ عملية رفع الملف إلى حسابك في جوجل درايف . بعد إتمام عملية الرفع بنجاح ، يتم عرض المساحة المستخدمة من المساحة التخزينية لحسابك ( وهي 15 جيجا ) ، والنسبة المئوية للمساحة في عنوان النموذج ، كما في الصورة أدناه لعملية الرفع . زر "نسخ الرابط" لنسخ الرابط بعد أن تمت عملية الرفع بنجاح ( لإستخداماتك الشخصية وحاجتك لاحقاً ) . وفيما يلي ، صورة سريعة لعملية رفع صورة على سبيل المثال : ملف الأداة بنسختين .. نسخة 64 بت نسخة 32 بت Uploader.zip Uploader 32.zip

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

السلام عليكم مشاركة مع اخي خليفة كود لتكرار السجل في الجدول نفسه في المثال : فقط انقر نقرا مزدوجا على حقل الاسم الذي تريد تكراره DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Test2.rar

شكرا استاذ على الالتفاتة الطيبة موضوع وهو تعديل على كود اقتطاع الانخراط بالاصح العامل الذي يدفع المبلغ 3000 خلال جانفي او فيفري او افريل او ماي او جوان يستنثني من الاقتطاع خلال شهر مارس و جويلية الكود Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click ' .......................... الشطر الاول اقتطاع القروض Dim rst As DAO.Recordset 'Cridi and Elec Payments Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.txtMonth & "')") rst.MoveLast: rst.MoveFirst Rc = rst.RecordCount a1 = 0 'just a flag a2 = 0 'jusf a flag If Rc = 0 Then: MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.txtMonth, "mmmm") & " " & Year(Me.txtMonth), vbInformation: Exit Sub If Len(rst!Payment_Made & "") = 0 And Not IsNull(rst!Loan_Made) Then Select Case MsgBox("هل تريد أن يتم توزيع الإقتطاعات لشهر " & Me.txtMonth, vbYesNo + vbQuestion + vbDefaultButton1) Case vbYes For i = 1 To Rc rst.Edit If rst!Nr >= 6 Then rst!Payment_Made = 0# Else If rst!Loan_Type = "Cridi" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If If rst!Loan_Type = "Elec" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If End If If rst!sadad.Value = True Then rst!wada3 = "تم التسديد" Else rst!wada3 = "لم يتم التسديد" End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update rst.MoveNext Next i 'End Select 'GoTo I_am_Done ' ..........................الشطر الثاني اقتطاع الانخراط 'Other loans for, March (3) and July (7) If Month(Now()) = 3 Or Month(Now()) = 7 Then Dim rstE As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans") myCriteria = "([detach]='موظف'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت كامل'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='حارس متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='عون نظافه وتطهير')" Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria) rstE.MoveLast: rstE.MoveFirst Rc = rstE.RecordCount For i = 1 To Rc rst.FindFirst "[Loan_Type]='Inkhirat' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.txtMonth & "#" If rst.NoMatch Then rst.AddNew a2 = 1 rst!EmployeeID = rstE!EmployeeID rst!Loan_ID = 0 rst!Payment_Month = DateSerial(Year(Me.txtMonth), Month(Me.txtMonth), 1) rst!Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") rst!Loan_Type = "Inkhirat" rst!Nr = GetNumDetach(rst!EmployeeID) rst!Remarks = "إقتطاع من الراتب لإنخراط شهر " & Year(Me.txtMonth) & "/" & Month(Me.txtMonth) rst!annee = Year(Date) If rst!Loan_Type = "Inkhirat" Then rst!sadad = rst!Payment_Made If rst!sadad.Value = True Then rst!wada3 = "تم الإنخراط" Else rst!wada3 = "لم يتم الإنخراط" End If End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update rstE.MoveNext Next i rstE.Close: Set rstE = Nothing End If TheSum = Format(TheSum, "#,##0.00") MsgBox " " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات = " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date) I_am_Done: Case vbNo MsgBox "لم يتم توزيع الإقتطاعات" End Select rst.Close: Set rst = Nothing End If Exit Sub err_cmd_Pay_installments_Click: If Err.Number = 3021 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub ملاحظة : الكود ينتقل الى الاقتطاعات خلال شهري مارس وجويلية فقط الفورم FrmTransfer اول مرة عند فتحه عند دخول الشهر يذهب الى الاكواد عند الفتح اتمنى ايجاد حل في القريب العاجل 20250126.rar

شكرا جزيلا أخي الفاضل وبارك الله فيك وأكثر الله من امثالك وزادك الله من علمه

شكرا جزيلا اخي الفاضل ملحوظة : الملف لم فتح عندي لأني استعمل اوفيس 2010 32 بت مذا افعل ؟

وعليكم السلام ورحمة الله تعالى وبركاته حاول دمج الأكواد السابقة في كود واحد لتتمكن من طباعة وصل معين أو عدة وصولات من إختيارك بالطريقة التالية Sub Choose_the_print() Dim tmp As Variant, arr As Variant, n As Range Dim OnRng As String, xInput As String, a(1 To 6) As String Dim WS As Worksheet: Set WS = Sheets("ورقة1") a(1) = "H2:L16": a(2) = "N2:R16": a(3) = "T2:X16": a(4) = "H18:L32": a(5) = "N18:R32": a(6) = "T18:X32" xInput = InputBox("يرجى إدخال أرقام الوصولات للطباعة" & vbCrLf & "مفصولة بفاصلة (-) مثل: 3-2-1", "إختيار الوصولات") If Trim(xInput) = "" Then: MsgBox "لم يتم إدخال أي أرقام يرجى المحاولة مرة أخرى", vbExclamation: Exit Sub tmp = Split(xInput, "-") For Each arr In tmp If IsNumeric(Trim(arr)) Then If Val(arr) >= 1 And Val(arr) <= 6 Then OnRng = a(Val(arr)) Set n = WS.Range(OnRng) n.PrintOut Copies:=1, Collate:=True Else MsgBox "رقم الوصل " & arr & " غير موجود يرجى التأكد", vbExclamation Exit Sub End If Else MsgBox "إدخال خاطئ " & arr, vbExclamation Exit Sub End If Next arr MsgBox "تمت الطباعة بنجاح", vbInformation End Sub مثال.xlsm

وعليكم السلام ورحمة الله وبركاته حسب فهمى لطلبك اليك الملف مثال (1).xlsm

الله الله عليك يا استاذنا @kkhaliffa 1960 شكرا جزيلا لك ولكل القائمين على هذا المنتدى العظيم، وجزاك الله كل خير وجعلها في ميزان حسناتك فعلا هذا ما احتاج اليه : سلمت ايديك وأحسن الله خاتمتنا واياكم يا رب العالمين

تفضل الاقساط السنوية غير المدفوعة (1).accdb

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

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip

اخي العزيز إضافة العمود المساعد لتحسين قابلية التعامل مع البيانات باستخدام المعادلات العادية (بدلاً من الصفيفية). عندما نريد تصفية البيانات (مثل ملفك)، يمكننا استخدام معادلات مثل INDEX وMATCH لتحديد الصفوف المطلوبة. ومع ذلك، هذه المعادلات تحتاج إلى طريقة لمعرفة الصفوف التي تحقق الشرط. العمود المساعد يعمل كـ "علامة" تحدد الصفوف التي تحقق الشرط (J9 < D2) وتُظهر رقم الصف الخاص بها. وإذا لم يتحقق الشرط، يُظهر العمود قيمة فارغة ("") القيم الموجودة في العمود X هي رقم الصف الذي ينحقق به الشرط في D2 طبعا يمكن الاستغناء على العمود المساعد باستخدام معادلات صفيفية أو حلول برمجية (مثل VBA) والعمود المساعديساعد على تحسين الأداء في النسخ القديمة من Excel مثل 2010 النسخ الحديثة 2019 وما فوق يمكن استخذام دالة FILTER وحقيقة انا لا املك في جهازي الا اصدار 2016 فلا يمكننى التجربة واخير يبقى الكود افضل مم سبق دكره واسرع ويمكن ان يكون تلقائيا بدون زر اليك ملف به حلات اخران الاول بمعادلات عادية بدون عمود مساعد والاخ على اليسار بالمعادلات الصفيفية 1شيت.xlsx حل اخر ويعنبر افضلهم بدون معادلات وبدون زر .عند الكنابة في D2 تتم الفلترة للدرجات ولا تنسى تمكين الماكرو شيت1.xlsb اتمنى فيما دكر بعض الفائدة نحياتي

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

وعليكم السلام ورحمة الله وبركاته طريقتان واختاري ما يتاسبك الاولى ان يكون الملفان مفتوحان في نفس الوقت ونفس المجلد وبنفس الاسم تحديث عدد الطلاب2 ( يمكن تعديله من الكود) ملف الطلاب الاصل.xlsb الثانية الملف مقفول وبأي اسم بمعنى عند الضغط على زر تحديث البيانات تظهر واجهة نخنار الملف المراد اخد البيانات منه ملف الطلاب الاصل2.xlsb اتمنى ان يكون طلبك في احد الملفين لك كل التقدير والاحترام

بناءً على طلب وملاحظة الأستاذ موسى ( مشكوراً )، تمت التعديلات الجديدة في النسخة التالية بحيث :- ♻ تظهر أسماء الأعمدة البرمجية والعناوين التي تخصها في الصف الأول كما في الصورة أدناه ( مثال ) .. ♻ الفكرة تم تطبيقها على الإستيراد المتعدد والغير متعدد أيضاً .. 💢 Excel Importor 2025.accdb 💢

السيد Khorsheed Omar المعادلة =IF([@[الاسم الثلاثي]]<>""; VLOOKUP([@[الاسم الثلاثي]]; 'البيانات الأساسية'!$A$2:$R$100;MATCH("2.2025"; 'البيانات الأساسية'!$1:$1; 0); FALSE); "") 1رواتب.xlsm

الدرس الاول في UserForm عناصر الدرس 1- اضافة التبويبات الرئيسية للفورم 2- اضافة MultiPage والتحكم في الانتقالات بينها من خلال التبويبات الرئيسة باستخدام Class Module اولا : اضافة التبويبات الرئيسية 1- نقوم باضة userForm ثم نضيف اطار Frame ونضيف داخله عدد 5 Lebel بالنسبة لعنوان اكتب ما تشاء عربي انجليزي لكن المهم Label Name ( Btn1-Btn2-Btn3-Btn4) ا BackStyle =0 BorderStyle=0 واليبل الخامس لتغير خلفية النص Name=AnlBtn BackColor=&H8000000E& ثم نضيف ليبل خاص بالعنوان نسميه PageNo ثم نضيف MultiPage ونضيف في ال Page1 ثانيا ربط التبويبات بالفورم نضيف Class Module نكتب داخله الكود التالي Public WithEvents LblBtn As MSForms.Label Private Sub LblBtn_Click() ' للحركة بين التبويبات UserForm1.AniBtn.Left = LblBtn.Left 'ربط صفحات المالتي بيج مع التبويبات UserForm1.MultiPage1.Value = Right(LblBtn.Name, 1) - 1 'شريط العنوان UserForm1.PageNo.Caption = "Page No " & UserForm1.MultiPage1.Value + 1 & " ( " & LblBtn.Caption & " )" End Sub وفي الفورم Dim LblEvent(3) As New Class1 Private Sub UserForm_Initialize() With Me.MultiPage1 'لتغير استايل المالتي بيج .Style = fmTabStyleNone: .Value = 0 End With 'عدد التبويبات 4 من صفر الي 3 For AddEvent = 0 To 3 Set LblEvent(AddEvent).LblBtn = Me("Btn" & AddEvent + 1) Next AddEvent End Sub الملف بالمرفقات ياريت ننفذ الخطوات ولو اي استفسار ماتترد اتمني من الله اكون بسط الشرح ويكون فيه الاستفادة مع تحياتي MultiPage Officana.xlsm

اتفضل هناك احتمال ان لا يشتغل نموذج كلندر وجزاك الله كل خير VBALibraryAccessVer4-2003.zip

اتفضل VBALibraryAccessVer4.rar

اخى الكريم حماده عمر بارك الله فيك على هذا المجهود الرائع جعل الله اعمالك فى ميزان حسناتك ولكن اخى الكريم اسمح لى ان اقوم باضافه بسيطه اعتقد انك قد نسيت ان تقوم بها وهى اننا طالما باستخدم الاكواد فانا ارى انه من الافضل عدم وجود معادلات فى الشيت لذلك قمت بتعديل استخراج المدين والدائن والرصيد عن طريق الكود كما قمت بادراج تاريخ اليوم فى الخليه H1 وذلك باضافه كود Sub sama2 فى موديل2 ارجو ان اكون قد وفقت فى تقديم بعض اللمسات الجميله على الكشف وذلك لمن لم يكن لديه المعرفه استخراج كشف حساب مع زر طباعة.rar

السلام عليكم اخي الكريم انني لم اجد حلا سريعا لطلبك ولكن لدي ملف قد يساعدك في انجاز ماتريد 5_توزيع_الأقساط_ومتابعتهاQest.rar