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

يمكنك استعمال هذه المعادلة في K2 ونسخها كما تشاء =SUMPRODUCT(SUBTOTAL(3,OFFSET($A$7:$A$29,ROW($A$7:$A$29)-MIN(ROW($A$7:$A$29)),,1))*($B$7:$M$29=J2)) وفقنا الله جميعا لكل خير

يمكنك استعمال هذه الدالة المعرفة Function daysnames(d As String, m As Integer, y As Long) As String Dim x As Long, s As String, days: s = "": days = Split(d, "-") For x = 0 To UBound(days) s = s & IIf(x > 0, " و", "") & Format(DateSerial(y, m, days(x)), "dddd") Next x daysnames = s End Function وطريقة استخدامها =daysnames(D2,F2,G2) وبعد استعمالها تعامل مثل الدوال الموجودة في الاكسل من حيث تحديث بيانات الخلية مباشرة بدون الضغط على زر للتحديث بالتوفيق

تفضل اخي اليك طلبك يمكنك تطويعه على حسب احتياجاتك Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet arr(1) = "المرجوا التحقق من إسم ورقة العمل" arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng If dico <> Empty Then Application.ScreenUpdating = False If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet: f.Name = dico: f.DrawingObjects.Delete: f.UsedRange = f.UsedRange.Value For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub Create-Sheets.xlsb

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

العملية بسيطة وممكن الوصول لذلك باكثر من طريقة طريقة استخدام الشروط لكل خانة خيار وهي طريقة تؤدي الغرض ولكنها تستدعي التكرار وصف اسماء الخانات ووو ... لا تعجب اخونا شايب الطريقة الثانية اذا كنا نرغب في تطبيق العمل على مجموعة من خانات الاختيار بدون استثناء ماعدا الخانة التي يتم النقر عليها فيمكن كتابة اجراء فرعي يمر على كافة الخانات في النموذج ويقوم باستبدال قيمتها الى 0 ماعدا الخانة التي تم اختيارها Sub x() Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = 105 Then ctl.Value = 0 End If Next ctl Me.ActiveControl = -1 End Sub ويتم استدعاء الاجراء عند النقر x اما اذا اردنا تطبيق الامر على بعض الخانات واستثناء البعض منها فيمكن بدلا من الاشارة الى نوع خانات الاختيار وهي هنا 105 بدلا من ذلك نستخدم خاصية tag ويكون الاجراء Sub x() Dim ctl As Control For Each ctl In Me.Controls If ctl.Tag = "*" Then ctl.Value = 0 End If Next ctl Me.ActiveControl = -1 End Sub ويستدعى بنفس الطريقة في الصورة تم تطبيق الامر على خانة اختيار وقيمتها 105 وخانة تدقيق وقيمتها 106 الشايب

مشاركة مع الغالي @عمر ضاحى جرب واعلمنا بالنتيجة <><><><><><><><><> DoCmd.GoToRecord , , acFirst For i = 1 To Me.mh1 kan = "" If Me.daraja <> "" Then Me.CurrFasl = "F" kan = Me.daraja End If DoCmd.GoToRecord , , acNext Next i For ii = 1 To Me.Recordset.RecordCount If Me.daraja = kan Then Me.CurrFasl = "F" DoCmd.GoToRecord , , acNext End If Next ii MsgBox "لقد تم بنجاح", vbOKOnly

لإرسال رسالة واتس اب اولاً / يجب تثبيت الواتس اب على الكبيوتر الخاص بك ثانياً / هذه هي الشفرة الأساسية للإرسال whatsapp://send?phone=" & "" & "&text=" & "" ثالثاً انشئ موديول جديد و الصق فيه الشفرة التالية Public Function SendMsg(Phon_Number As Variant, TexTMag As String) Dim StrURL As Variant Dim StrToNumber As Variant Dim StrMsg As Variant StrToNumber = Phon_Number StrMsg = EncodeQP2(TexTMag) StrURL = "whatsapp://send?phone=" & StrToNumber & "&text=" & StrMsg CreateObject("WScript.Shell").Run StrURL, 1, False Call StartTimer(3) Call SendKeys("{ENTER}") End Function Public Function EncodeQP2(s As String) As String Dim i As Long Dim p1 As Long Dim p2 As Long Dim r As String Dim n As Long For i = 1 To Len(s) n = AscW(Mid(s, i, 1)) If n < 128 Then r = r & "%" & Hex(n) ElseIf n < 2048 Then p1 = n \ 64 r = r & "%" & Hex(p1 + 192) p2 = n Mod 64 r = r & "%" & Hex(p2 + 128) Else End If Next i EncodeQP2 = r End Function Public Function StartTimer(NumberOfSeconds As Variant) On Error Resume Next Dim PauseTime, Start, Finish, TotalTime PauseTime = NumberOfSeconds Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Finish = Timer TotalTime = Finish - Start End Function ثم في النموذج الخاص بك و في ازرار الارسال Call SendMsg("966590000000", "السلام عليكم")

موفقين جميعا بإذن الله من أفضل ما يميز الحلول التقنية والبرمجة المرونة وتقديم نفس الحل بطرق متعددة جعلنا الله جميعا من السابقين في فعل الخيرات

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

يكون المعيار بهذا الشكل WHERE Year([datein] Between Year(Now()) And Year(Now())-3 النتيجة New Microsoft Access Database 1.accdb

مشاركة مع الاساتذة بدون الحاجة لاستعلام فقط نتعامل مع مصدر السجلات ونسنده للنموذج الفرعي ثم نستخدم حلقة دوارة تعدل قيمة الحقل في زر الامر اختيار الكل نضع الامر Dim rst As Recordset Dim a As Integer Set rst = Me.Sub.Form.Recordset rst.MoveFirst For a = 0 To rst.RecordCount - 1 rst.Edit rst!drawn = -1 rst.Update rst.MoveNext Next a Me.Sub.Requery وفي زر الغاء الكل نضع Dim rst As Recordset Dim a As Integer Set rst = Me.Sub.Form.Recordset rst.MoveFirst For a = 0 To rst.RecordCount - 1 rst.Edit rst!drawn = 0 rst.Update rst.MoveNext Next a Me.Sub.Requery الملف مرفق الشايب تحديد الكل والغاء الكل.accdb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد أ / محمد صالح وبما انه جاء في طلبك انك ترغب باستخدام الاكواد لابأس في اثراء الموضوع بالكود التالي Sub Extract_days() Dim WSData As Worksheet Dim rng As Range, strDays As String Dim Col As Variant, arDays As Variant Dim iDays As Long, lr As Long, i As Long Set WSData = Worksheets("ورقة2") Application.ScreenUpdating = False WSData.Range("E2", Range("E" & Rows.Count).End(3)).ClearContents With WSData lr = .Range("D" & Rows.Count).End(xlUp).Row Set rng = .Range("B2:G" & lr) Col = rng.Value End With On Error Resume Next For i = 1 To UBound(Col) strDays = "" arDays = Split(Col(i, 3), "-") For iDays = 0 To UBound(arDays) strDays = strDays & "-" & Format(DateSerial(Col(i, 6), Col(i, 5), arDays(iDays)), "dddd") Next iDays Col(i, 4) = Right(strDays, Len(strDays) - 1) Next i On Error GoTo 0 With rng.Columns(4) .Value = Application.Index(Col, 0, 4) '.Columns.AutoFit End With Application.ScreenUpdating = True End Sub الغياب2.xlsm

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

مشاركة مع اخي الاستاذ @محمد احمد لطفى ضعي الكود التالي تحت زر تحديد الكل DoCmd.RunSQL "UPDATE test_order_tbl SET drawn=true;" Me.Requery والكود التالي تحت زر الغاء الكل DoCmd.RunSQL "UPDATE test_order_tbl SET drawn=false;" Me.Requery تفضلي الملف تحديد الكل والغاء الكل.rar

شكرا على ردك ,تحياتي لك

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

@محمد هشام. أستأذنك إستفسار بسيط عند أخذ أمر النسخ تكون النسخ الجديدة كلها ( Values & Sources Formatting ) ، هل يمكن أن تكون النسخ التى تتم تكون كما هى بالمعادلات و الـ Format بعتذر لك على الإزعاج

العفو اخي يسعدنا اننا استطعنا مساعدتك

@أ / محمد صالح ما شاء الله العلى العظيم بارك الله بحضرتك ونفع بك " الحل جميل جدا وممتاز " سيكون لك نصيب من الثواب بالمشروع ( تحليل ايات القران والحروف والوصول للاعجاز الرقمى بالقران الكريم)

انت عندك حاجتين اما خانة اختيار او مجموعة اختيارات

تفضل أخي اضافة ترقيم تلقائي للسند . جدول عام-2.rar

ان كنت تحتاجها في الاستعلام ...جرب المرفق بدون أيام الإجازة.rar

مشاركة مع اخي @Foksh المفروض اذا اضفت 7 ايام الى تاريخ 16/11/2023 تكون نهاية العمل بتاريخ 26/11/2023 (داخل) اي نهاية الدوام الرسمي اما اذا اردت ان يكون التاريخ 27/11/2023 ..اضف يوم الى هذا السطر daysNumber = Me.daysNumber.Value +1 بدون أيام الإجازة.accdb

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

تفضل BASET5.rar

تفضل أخي مرفقك حولته باللغة الانجليزية والبيانات مترجمة بالجداول ، ......... ووافني بالرد . DD412.rar

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد محمد صالح اليك حلول اخرى =INDEX($B$2:$D$6, MATCH(A10,$A$2:$A$6,0), MATCH(B10, $B$1:$D$1, 0)) او =HLOOKUP(I12,$H$1:$K$6,MATCH(H12,$H$1:$H$6,0),0) اوفيسنا.xlsx

إرفاقك للملف يوفر على من يساعدك تصميم ملف يشبه هذا الوضع على العموم يمكنك تجربة التالي =VLOOKUP(A10, $A$2:$D$6, MATCH(B10, $A$1:$D$1,0)) على اعتبار أن البيانات في الصف الأول والاستعلام في الصف العاشر بالتوفيق

وعليكم السلام Sub Test() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Rows("1:2").RowHeight = 30 ws.Rows("3:" & Rows.Count).RowHeight = 20 Next ws End Sub

وعليكم السلام ورحمة الله تعالى وبركاته في حالة الرغبة في استخدام الاكواد يمكنك تجربة المرفق التالي date3.xlsb

استبدل المعادلة ال انت عاملها بالمعادلة ال انا مديهالك واجعلها هكذا CalcVac(DateDiff("d";[Date_jop];Date());DateDiff("yyyy";[DateOfBirth];Date())) زان شاء الله هتظبط معاك VACATIONS22.rar

هذا الخطأ معناه ان هناك حقل [Org_Name] هذا الحقل متكرر فى اكثر من جدول بنفس الاسم يجب ان يكون هناك اختلاق بين التسميات زود حرف فى باقي الجداول او ارقام لتميز كل حقل عن الاخر

برنامج العقود - 4.accdb

تفضل اخي يمكنك اختيار ما يناسبك Option Explicit ' الغاء فلترة جميع اوراق العمل Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode = True Then Debug.Print WS.Name WS.AutoFilterMode = False End If Next End Sub '**********او*********** Sub Sup_tous_les_filtres2() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode Then WS.AutoFilter.Range.AutoFilter End If Next End Sub '********تحديد تسلسل معين *********** Sub vSup_tous_les_filtres3() Dim i As Long Dim compteur As Long ' عدد اوراق العمل compteur = 100 ' من ورقة 1 الى 100 For i = 1 To compteur On Error Resume Next If Sheets(i).AutoFilterMode Then Sheets(i).AutoFilter.Range.AutoFilter On Error GoTo 0 End If Next i End Sub

بارك الله ولك وللقائمين على المنتدى جميعا مثلما دعوت

تفضل اخي الكريم New Microsoft Excel Worksheet.xlsx.rar

وعليكم السلام - يمكنك بإستخدام هذا الكود وتكراره لكل تكست بوكس على حده .. وطبعاً تم الرد بالكود وليس بملف لأنك لم تقم برفع ملف توضيحى من البداية لطلبك !!! Private Sub TextBox5_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) With TextBox5 If IsDate(.Text) Then .Text = Format(DateValue(.Text), "dd/mm/yyyy") Else MsgBox "Not a date" Cancel = True End If End With End Sub

حاول اخي تحميل الملف من المرفقات وقم بنسخ المعادلات =MAX.SI.ENS($F$2:$F$7000;$C$2:$C$7000;K2) او =MAX(SI($C$2:C7000=K2; $F$2:F7000)) او =SOMMEPROD(MAX(($C$2:$C$7000=K2)*($F$2:$F$7000))) او =MAX(INDEX((K2=$C$2:$C$7000)*$F$2:$F$7000;)) H23_V2.xlsx

جبر المعادلة.xlsمعادلات أو Sub Test() Range("H2").Resize(Range(Cells(2, 7), Cells(2, 7).End(xlDown)).Cells.Count).FormulaR1C1 = "=CEILING(RC[-1],5)" End Sub

مرفق الملف استاذنا جبر المعادلة.xlsx

وعليكم السلام -بما انك لم ترفع ملف اكسيل موضح به المطلوب بكل دقة -فتفضل هذا به طلبك HRDISCUSSION.COM_برنامج تسيير المطاعم.rar برنامج تسيير المطعم المدرسي.xls

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والمتواضعة ( زاد المثابر للحصول على أسماء العناصر) هذه الأداة صممتها بفضل الله في أكسس تقوم بإحضار وسرد أسماء العناصر لك لكي تستطيع نسخها ولصقها في أي مكان تريد بكل سهولة ويسر 🙂 شخصيا أستفدت كثيرا منها وسهلت علي الكثير من الجهد وقلصت من وقت العمل بحمد الله وفضله. وهنا اختصرت على نفسي الكتابة وقمت بشرح الأداة مرئيا 🙂 متابعة ممتعة 😊👌🏼 ولا أستغني عن آراءكم وملاحظاتكم .. 🙂 لتحميل الملف المستخدم في الشرح وبه النموذج : التحديث 2.0 : تم إضافة خاصية جلب عناصر النماذج الفرعية .. والتقارير الفرعية .. شكرا للأخ @عمر ضاحى على الفكرة 🙂

وعليكم السلام -يمكنك استخدام هذه المعادلة دون حذف العمودان المساعدان T & U =C3&" "&VLOOKUP($B3,$T$2:$U$80,2,0) معادله شرطيه.xlsx

مثال توضيحي.xlsx