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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة لأنشاء الجداول بطريقة مختلفة عن الطريقة التقليدية التي نعرفها .. إلا أنها ما زالت قيد التطوير الفكرة تعتمد على نموذج واحد فقط يمكّن المستخدم من إنشاء جداوله والحقول التي تحتويها ونوع الحقول بشكل سهل وبسيط . أولاً انقر على الزر " أنشاء حقل جديد ... " ثانياً قم بملئ الحقول ( اسم الجدول ، اسم الحقل ، نوع الحقل ) ، عند اختيار نوع الحقل سيتم إضافة الحقل الجديد الى الـ List Box تسلسلاً حسب الإدخال . عند الإنتهاء من إدخال جميع الحقول وأنواعها ، انقر الزر " إنشاء الجدول ... " ، وهنا سيتظهر رسالة تفيد بأنه ( لابد من وجود حقل مفتاح أساسي ، هل ترغب بتعيين حقل مفتاح أساسي ؟ ) عند اختيار Yes - نعم سيتم تعيين أول حقل كمفتاح أساسي ؛ وإذا تم اختيار No - لا سيتم انشاء الجدول دون مفتاح أساسي . عند إنشاء الجدول سيتم تصحيح عدة نقاط بشكل تلقائي وهي :- إزالة المسافة من اسماء الجداول واستبدالها بـ " _ " . إضافة الجزء "_Tbl" الى اسم الجدول عند انشائه . أيضاً إزالة المسافة من أسماء الحقول واستبدالها بـ " _ " . الملف مفتوح المصدر TBL Maker.accdb بناءً على إقتراحات أستاذي وصديقي @Moosak ، والتعديلات التي تقدم بها صديقي وأستاذي @ابو جودي ، تم دمج وإضافة تعديلات جديدة أرجو أن تنال رضاكم وإعجابكم . تم إضافة ميزة أن يكون في الجدول أكثر من حقل مفتاح أساسي . تم إضافة ميزة التعديل على الحقول أو حذف أحد الحقول قبل إنشاء الجدول من خلال زر " تعديل الحقول " ، وبعد إجراء التعديلات انقر زر " تأكيد التعديل ". تم دمج ميزة حرية إضافة " _Tbl " الى اسم الجدول عند انشائه ( فكرة الأستاذ أبو جودي مع إجراء تعديل بسيط ) - إختياري . تم دمج ميزة أن يكون أسماء الجداول والحقول ( الإنجليزية ) تبدأ بحرف كبير Capital Letter . تم إضافة ميزة فتح الجدول بعد انشائه لرؤية النتيجة أو لإدخال البيانات - إختياري . تم إضافة زر " مفتاح أساسي " لتمكين المستخدم من اختيار الحقول التي يريدها أن تكون مفتاح أساسي . تم إضافة زر " إضافة حقل " لإضافة حقل جديد . تم تعديل التصميم بشكل بسيط ليتناسب مع محتوياته والميزات الجديدة . ✔ لا حاجة لأي مكتبات أو مديولات عند نسخ النموذج لمشروعك والبدء بالإستفادة من ميزاته . ✔ أتطلع لأي أفكار جديدة أو اقتراحات TBL Maker.accdb680 kB · 7 downloads تم تعديل منذ 7 ساعات بواسطه Foksh

بناءً على إقتراح أستاذنا @Moosak تم إضافة ميزة " التسمية التوضيحية - Caption " للحقول . تم إضافة ميزة " التعرف على حقل الترقيم التلقائي " عند وجوده والتخيير بين جعله مفتاح أساسي أو لا . في حال عدم وجود حقل ترقيم تلقائي ، سيتم التنبيه بعدم وجوده وإنشاء حقل جديد ID = AutoNumber ؛ والتخيير أيضاً بإنشائه أو لا . وعند إنشائه سيكون له خاصية مفتاح اساسي PrimaryKey . 💡ملاحظة : في التعديل القادم سيتم إتاحة الفرصة للمستخدم بالتعديل على الحقول قبل إنشاء الجدول كخطوة أخيرة 🤗 TBL Maker.accdb

السلام عليكم اعتذر جدا جدا جدا لكم اساتذتى الافاضل @Moosak , @عمر ضاحى اثناء تجربتى للتعديلات لم اقم الا باضافة حقل واحد لضيق وقتى لذلك لم تظهر المشكلة والان بفضل الله تم تدارك المشاكل وحلها جميعا يرجى الرد بنتيجة التجربة وانتظروا تحديث جديد ان قدر الله لنا اللقاء ان شاء الله Create advanced tables V 2.0.1 .accdb

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

سأكشف لكم عن سر 👀 كنت قد بدأت منذ عدة أيام بإنشاء طريقة تساعد على عمل قوائم مختصرة للنماذج ، ولكنها أخذت مني وقتاً وجهداً كبيرين ، وتوقفت عند مرحلة إعادة تجميع الأفكار 😇 💡 قريباً النسخة الأولى 💡

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

السلام عليكم تفضل الحل بالأكواد تضع كافة الملفات في مجلد (فولدر واحد) وتضع معهم هذا الملف suppliers.xlsm المرفق تفتخه وتضغط الزر ، يبدأ في عمل التالي فتح الملفات الواحد تلو الأخر استدعاء البيانات من الملف المفتوخ ونسخها للملف الأصلي غلق الملف المفتوخ ثم تكرار الخطوات الثلاثة ختي نهاية الملفات في الفولدر مهما كان عدد الملفات suppliers.xlsm

شوف هذا راى ولك طبعا مطلق الحرية انا عن نفسى افضل استخدام اسماء الجدول بالطريقة الاتية tblOfficenaForms ممكن حد تانى يحبها كده tbl_Officena_Forms انا وضعت دالة لتحويل اول حرف من كل مفطع الى حرف كبير وباقى الاحرف صغيرة وترطت للمستخدم حرية الاختيار فى موضوع ال Under Score وطبعا انا اسف انا غلط فى كتابتها على النموذج بالشكل Use ChkUnder Score لانها مفروض كانت تكون Use Under Score و\بعا جمبها او تحتها تلميح لتوضيح الوظيفة بس وقتها كنت خلاص رايح الشغل وضيق وقتى خلانى اقع فى المشكلة الالولى اللى اظهرت الرسائل مع اكثر من حقل طبعا انا اول التعديل كتبت الكود بصراحة ان تكون النتيجة بالشكل التالى tblOfficenaForms وبعدين فلت ليه افرض رأى فى الكود ولذلك فكرت فى استخدام Optional علشان اسيب للجميع حرية الاختيار وعدلت الكود تانى على هذا الاساس لاحظ كده فى الفترى الاخيرة تحديدا كل ما اقدمه احاول بقدر الامكان تحقيقة باكبر قدر ممكن من المرونه حتى وان تطلب هذا جهدا فى التفكير وانشاء وترتيب الافكار فى الكود وان ذادت اسطر الكود لا ابالى شوفت مرفق لعبة الكلمات المتقاطعة ؟ من هنا كنت عاملة بسيط من زمان جدا جدا على سبيل التسلية وقتها ولم اكمل العمل ولكن بعد مشاهدتى لموضوع الاستاذ @Moosak صحى الطفل اللى جوايا وذكريات الماضى لانه كنت و والدى رحمه الله تعال وكل المسلمين يوميا نلعبها فى الجرائد ونلعب ونضخك وقت الافطار بعد صلاة الفجر و وقت الشروق ولكن بصراحة لانه احبه جدا فى لله قلت اعاكسة ويلا بقى تحدى.... طبعا امزح انه اخى الحبيب ولكن انا تعلمت الكثر بسبب فقط عاصفة الافكار التى اجتاحتنى وقتها

حيلك حيلك يا عم انت رايح فين هههه فرمل و وقف وخد نفس ؛ إنت ما صدقت يا سيد بمزح والله يا محمد مش قصدي كل اللي خطر في بالك مش قلتلك من زمان ما نكشتكش وهزرت معاك هههههههههه

انت اي حاجه بتعملها بتبقي جامده يا بروف 😉 😉 ولا اقولك يا MPV بروف ☺️ ☺️ انت مش فنان انت دائما مبدع لو عملت نموذج فاضي حتي هيكون اختراع 🙄🙄 انا مش بحسد انا بقر بس 🤣🤣

اولا ::: هناك اخطاء لديك لانك استخدمت بعض الكلمات المحجوزة للاكسس ثانيا :::: اقتنصت بعض الاكواد من الخبير @jjafferr فله الشكر والعرفان جرب المرفق ربما هو المطلوب . Change by One Button.accdb

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

السلام عليكم ورحمة الله وبركاته السادة اعضاء المنتدى والخبراء الكرام أثناء بحثي في الإنترنت وجدت بعض النماذج للأزار تبديل (Toggle Button) حديثة فأردت مشاركتها معكم لكي تعم الاستفادة لعل أحدهم ينتفع بها. وشكرا جزيلا لكم 1.rar 2.rar

تفضل جرب هدا Private Sub b_recup_Click() Dim Cnt As VbMsgBoxResult Dim sht As Worksheet, tbl As ListObject, tblRow As ListRow Set sht = Sheets("تصدير بيانات اكسيل") Set tbl = sht.ListObjects("Table1") Cnt = MsgBox(" تــرحيل البيانات ؟", vbYesNo, sht.Name): If Cnt <> vbYes Then Exit Sub With tbl.DataBodyRange If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete End If End With tbl.DataBodyRange.Rows(1).ClearContents Set tblRow = tbl.ListRows.Add tblRow.Range.Resize(Me.ListBox1.ListCount) = Me.ListBox1.List sht.[b2] = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy") sht.[C2] = ("رصيد المدة"): sht.[F2] = ("بيان رصيد أول مدة بتاريخ هذا اليوم") sht.[G2] = Text_count: sht.[I2] = Text_count With sht.Cells(sht.Rows.Count, 6).End(xlUp).Offset(1) .Value = "الإجمالي" .Offset(, 1) = Me.TextBox3.Value .Offset(, 2) = Me.TextBox2.Value .Offset(, 3) = Me.TextBox1.Value End With MsgBox "تم نرحيــل البيانات بنجاح" Unload Me On Error Resume Next Set Rng = sht.Range("A1").CurrentRegion sht.PageSetup.PrintArea = Rng.Address sht.PrintPreview ' answer = MsgBox("طباعــة التقرير ؟", vbQuestion + vbYesNo + vbDefaultButton2, "تأكـــيد") ' If answer = vbYes Then sht.PrintOut End Sub تمت اظافة اكواد تصدير الملف بصيغة Word, Excel, PDF في الملف المرفق Copy of كشف حساب عميل & كارت صنف V5.xlsm

كل الاكواد بسطر واحد نموج واحد بسيط والكود بداخل الزر Sken_Calendr_One_Form.rar

The code is already OK as it exports data from the listbox to the worksheet Just comment out those two lines For X = 0 To ListBox1.ListCount - 1 Next X as I don't see any need to loop through the items of the listbox

السلام عليكم تفضل المرفق وقد تم الغاء العمود تنبية للوصول بسن المعاش 2.xlsm

بناءً على إقتراحات أستاذي وصديقي @Moosak ، والتعديلات التي تقدم بها صديقي وأستاذي @ابو جودي ، تم دمج وإضافة تعديلات جديدة أرجو أن تنال رضاكم وإعجابكم . تم إضافة ميزة أن يكون في الجدول أكثر من حقل مفتاح أساسي . تم إضافة ميزة التعديل على الحقول أو حذف أحد الحقول قبل إنشاء الجدول من خلال زر " تعديل الحقول " ، وبعد إجراء التعديلات انقر زر " تأكيد التعديل ". تم دمج ميزة حرية إضافة " _Tbl " الى اسم الجدول عند انشائه ( فكرة الأستاذ أبو جودي مع إجراء تعديل بسيط ) - إختياري . تم دمج ميزة أن يكون أسماء الجداول والحقول ( الإنجليزية ) تبدأ بحرف كبير Capital Letter . تم إضافة ميزة فتح الجدول بعد انشائه لرؤية النتيجة أو لإدخال البيانات - إختياري . تم إضافة زر " مفتاح أساسي " لتمكين المستخدم من اختيار الحقول التي يريدها أن تكون مفتاح أساسي . تم إضافة زر " إضافة حقل " لإضافة حقل جديد . تم تعديل التصميم بشكل بسيط ليتناسب مع محتوياته والميزات الجديدة . ✔ لا حاجة لأي مكتبات أو مديولات عند نسخ النموذج لمشروعك والبدء بالإستفادة من ميزاته . ✔ أتطلع لأي أفكار جديدة أو اقتراحات TBL Maker.accdb

قال مش داخل تاني قال ههههههههههههه وفين ألاقي ناس طيبة متل الناس اللي هنا على العموم انا بتعامل معاكم والله كأنكم أخواني وأصدقائي ليس إلا .. بحترمكم وبقدركم وبقدر جهودكم وتعبكم .. على العموم نرجع لموضوعنا وأنا حالياً عدلت وطورت فكرتي وبنيت على فكرتك تعديلات بسيطة ولكن استثنيت Use ChkUnder Score . وأرجو إبداء الرأي في المشاركة التالية حال الإنتهاء من اللمسات الأخيرة , كما أرجو تثبيت التحديث في أول الموضوع

سوف اقدم اليك النصح وانا اقل طويلب علم بالمنتدى ضع نصب عينيك دائما وابدا وبوجه خاص مع الاكسس البساطة قدر الامكان لانه صدقنى وعندما تكون البيانات اولا قليلة او قد يتتطلب مشروعك عمل وتنفيذ الكثير من الاجراءات وبالاخص ان كانت معقدة وام تم التعامل مع جهاز ضعيف او عبر استخدام القاعدة ضمن شبكة محلية قد تصيبك صدمة من استخدام ما قد يكون لو تأثير بالسلب على اداء وسرعة فاعدة البيانات لذلك انصحك بالبساطة اعلم انه فد ترى وتشاهد حركات وامور تكون مبهجة وقد تعجب بها جدا ولكن كما اخبرتك واليك مثال على الرئيسية على سبيل المثال expand and collapse button V3.zip

ماشي يا عم .. بيظهر في المواقع التالية :- 2. وجاري التعديل في نسخة جديدة محسنة بناءً على فكرتك إذا ما عندكش مانع لا سمح الله

مين قال انه صعب هذه الفكرة الاولى لتعديل المرفق الاساسى والتعديلات كالاتى - من الجدول : tblHolidaySettings يتم تحديد ايام الاجازات الاسبوعية لتغير لونها فى نموذج الـ frmCalendar لتكون باللون الاحمر ويمكن تغير اللون من الكود من السطر HolidayColor = vbRed - تم عدم تفعيل ايام العطلات تبعا للتواريخ الموجودة بالجدول : tblPublicHolidays - تم اضافة Label بأسفل النموذج frmCalendar لعرض تواريخ العطلات واسمائها والغير مفعلة فى النموذج ليكون المستخدم على علم بسبب عدم تفعيل هذه التواريخ calendar V 2.0 .accdb

رحم الله والديك .. وجمعك معهما في الفردوس الأعلى ,, وغفر لنا ولكم ولجميع المسلين

هتعدل الداله فقط بالشكل التالي Public Function HandleKeyDown(KeyCode As Integer, Shift As Integer) As Integer If (Shift And acShiftMask) > 0 Then ' إذا كان مفتاح Shift مضغوطًا Select Case KeyCode Case vbKeyC ' إذا كان المفتاح المضغوط هو C MsgBox "Shift + C تم الضغط على" HandleKeyDown = 0 ' لمنع إدخال بيانات في الحقل الحالي Exit Function End Select ElseIf (Shift And acCtrlMask) > 0 Then ' إذا كان مفتاح Ctrl مضغوطًا Select Case KeyCode Case vbKeyB ' إذا كان المفتاح المضغوط هو B MsgBox "Ctrl + B تم الضغط على" HandleKeyDown = 0 ' لمنع إدخال بيانات في الحقل الحالي Exit Function End Select Else Select Case KeyCode Case 115 ' F4 Form_Form1.k1.SetFocus HandleKeyDown = 0 ' لمنع إدخال بيانات في الحقل الحالي Case 114 ' F3 Form_Form1.k5.SetFocus HandleKeyDown = 0 ' لمنع إدخال بيانات في الحقل الحالي Case Else HandleKeyDown = KeyCode ' لإعادة KeyCode الأصلي لتمكين إدخال البيانات في الحقل End Select End If End Function بقيت التكست بوكس كما هي

هذا بالمعادلة تفضل راس الصفحة - معادلة.xlsx

جرب هل هدا ما تقصده tb1 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!G4:G100000,'" & WS.Name & _ "'!C4:C100000,{""مبيعات"";""قيد""},'" & WS.Name & "'!B4:B100000,""<""&'" & WS.Name & "'!Y1))") tb2 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!H4:H100000,'" & WS.Name & _ "'!C4:C100000,{""مردودات مبيعات"";""سند قيد"";""سند قبض""},'" & WS.Name & "'!B4:B100000,""<""&'" & WS.Name & "'!Y1))") result = tb1 - tb2 Me.Text_count.Value = Format(result, "#,##00.00") If Me.Text_count = 0 Then colDates كما ترى في الصورة التواريخ تظهر معي بالشكل المطلوب قم بتعديل تنسيق التاريخ على الجهاز الخاص بك الى dd/mm/yyyy او تعديل الكود Sub Filtre() If Me.DateMini = "" Or Me.DateMaxi = "" Then Exit Sub For i = 1 To 3 Me.Controls("TextBox" & i).Value = "" Next i S.Caption = "" Dim Tbl() cbx1 = Me.ComboBox1: cbx2 = Me.ComboBox2: cbx3 = Me.ComboBox3 n = 0 dMini = CDate(Me.DateMini): dMaxi = CDate(Me.DateMaxi) Cb = Array(1, 1, 1) For i = 0 To UBound(ColCombo): Cb(i) = ColCombo(i): Next i For i = 1 To UBound(TabBD) If TabBD(i, Cb(0)) Like cbx1 And TabBD(i, Cb(1)) Like cbx2 _ And TabBD(i, Cb(2)) Like cbx3 _ And TabBD(i, 2) >= dMini And TabBD(i, 2) <= dMaxi Then n = n + 1: ReDim Preserve Tbl(1 To Irow + 1, 1 To n) c = 0 For c = 1 To Irow: Tbl(c, n) = TabBD(i, c): Next c Tbl(c, n) = TabBD(i, Irow + 1) Tbl(2, n) = Format(TabBD(i, 2), "dd/mm/yyyy") ' تنسيق عمود التاريخ End If Next i If n > 0 Then Me.ListBox1.Column = Tbl SUMIF Else Me.ListBox1.Clear End If End Sub Copy of كشف حساب عميل -V3.xlsm

السلام عليكم ورحمة الله وبركاته اللهم اجعل هذا العمل خالصا لوجهك الكريم لكي تعم الفائدة : البرنامج مفتوح المصدر "الباسوورد 1374" ارجو الحرص في التعامل مع المعادلات . ان اخطأت اغلق بدون حفظ برنامج توزيع الطلاب على الاقسام ( خاص بالتعليم الفني ) صناعي _ زراعي _ تجاري _ فندقي _ مهني كل ما عليك هو تسجيل بيانات الطالب ( الاسم _ المجموع _ القومي ) فقط ثم احصل بعد ذلك على قوائم الفصول . البرنامج له جزئين . ويجب الربط بينهما الاول : لاستخلاص البيانات الثاني : قوائم الفصول الجزء الاول برنامج تنسيق مدارس_معدل.xlsb الجزء الثاني trheel_p_3_access.xlsb

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

السلام عليكم تفضل المرفق التكرار.xlsx

السلام عليكم و رحمة الله استخدم هذا الكود Sub AddRow() Selection.EntireRow.Insert , xlFormatFromLeftOrAbove End Sub

كنت دايخة اشوي😇 اشلون اضيف جدول واستعلام برقم السنة على سبيل المثال 2024 عيدالفطر اربع سجلات = اربع ايام اذا كان اليوم اجازة يخلي الزر عدم التمكين للضغط بدل ما استخدام كود Dim rung as integer For rung = 0 to dcount ("[day]","[Ejazh]") 'Query (Ejazh) if me(lebl).name = me.day then me(lebl).enable =false else true end if بطيئ عند التقلب بالشهور والسنوات ؟! هل يوجد تعديل للكود او كود آخر او طريقة ثانية وشكرا

ممتاز جاري التجربة اشكرك استاذ @Foksh ❤️🌹🌹 اذا تسمح لي باضافة تحويل الاستعلام الى جدول 🥰 Query IF tablet more from 6 8 tablet For Use DOA And DAO

روعة يا استاذنا

بدايةً ارجو أن تقوم بإنشاء تقريرك الذي تريد ان يتم طباعته بين التاريخين .. ثانياً هل تريد البحث بين التاريخين لتاريخ ميلاد الطالب ، أو تاريخ التسجيل ؟؟ اذا كان لتاريخ التسجيل ، فإليك الخطوات دون ملف مرفق :- 1. انشئ استعلام وحدد الحقول التي تريد جلب قيمها من الجدول ومن ضمنها طبعاً الحقل Reg كحقل أساسي . 2. في الحقل Reg من داخل الإستعلام وفي جزء الـ Criteria - الشروط اكتب السطر التالي :- Between [Forms]![بيانات الدور الثاني]![n1] And [Forms]![بيانات الدور الثاني]![n2] 3. احفظ الإستعلام ، وانشئ تقريرك المبني على هذا الاستعلام .

وإياكم أخي العزيز ,, شكراً لك

أحسنت أخي العزيز Foksh رائع جداً وجزاك الله خيراً وجودك في المنتدى يفرق كثيراً... أعطاك الله الصحة والعافية

جرب هذا التعديل للمرفق الأخير :- 2.zip تم إضافة حقل جديد في الجدول Reg_Status من نوع Yes/No ، وإضافة حدث في الحالي لتحديث القيمة لـ check1 بناءً على قيمة Reg_Status ، وتعديل الكود السابق في المشاركة السابقة لتحديث هذا الحقل أيضاً .

اعتذر منك أخت @hanan_ms ، ولكني هل يمكنك التوضيح للمطلوب بشكل أوضح ؟؟؟؟ اعتذر منك ولكن فعلاً لم افهم المطلوب رغم قراءتي له أكثر من مرة

وعليكم السلام ورحمة الله وبركاته .. قمت بإضافة حقل Reg لأنك لم تقم بتحديد الحقل الذي تريد اضافة القيمة له في الجدول ,, تفضل هذا الكود :- Dim strSQL As String If Me.check1.Caption = "o" Then Me.check1.Caption = "‏" strSQL = "UPDATE [بيانات الدور الثاني] SET Reg = Date() WHERE [رقم جلوس] = " & Me.رقم_جلوس CurrentDb.Execute strSQL, dbFailOnError Else Me.check1.Caption = "o" strSQL = "UPDATE [بيانات الدور الثاني] SET Reg = Null WHERE [رقم جلوس] = " & Me.رقم_جلوس CurrentDb.Execute strSQL, dbFailOnError End If وهذا ملفك بعد التعديل :- 1.zip

تفضل 12345معدل.xlsm

وعليكم السلام ورحمة الله وبركاته .. أنظر هنا لعلك تجد ما يعجبك 🙂 :

تفضل ان كنت فهمت عنك على عجل استخدمت الارقام الصريحة بدلا من المتغيرات اذا الفكرة هي مطلوبك يمكنك بسهولة تعديل الارقام الصريحة الى متغيرات Dim i As Integer i = Me.kulo If i >= 10 Then sh1 = 10 i = i - sh1 sr1 = sh1 * 15 Else sh1 = i sr1 = sh1 * 15 i = 0 End If If i >= 20 Then sh2 = 20 i = i - sh2 sr2 = sh2 * 20 Else sh2 = i sr2 = sh2 * 20 i = 0 End If If i >= 30 Then sh3 = 30 i = i - sh3 sr3 = sh3 * 25 Else sh3 = i sr3 = sh3 * 25 i = 0 End If If i >= 40 Then sh4 = 40 i = i - sh4 sr4 = sh4 * 30 Else sh4 = i sr4 = sh4 * 30 i = 0 End If If i >= 41 Then sh5 = i sr5 = sh5 * 50 Else sh5 = i sr5 = sh5 * 50 End If Me.srSum = Nz(sr1) + Nz(sr2) + Nz(sr3) + Nz(sr4) + Nz(sr5) b2.rar

حاول تجربة هدا من خلال اليوزرفورم Dim f Private Sub UserForm_Initialize() Set f = Sheets("ClassSheet") Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) d(c.Value) = "" Next c Me.ComboBox1.List = d.keys End Sub Private Sub ComboBox1_Change() Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) If c.Value = Me.ComboBox1 Then d(c.Offset(0, -1).Value) = "" Next c Me.ComboBox2.List = d.keys Me.ComboBox2.ListIndex = -1 Me.ComboBox3.ListIndex = -1 End Sub Private Sub ComboBox2_Change() Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) If c.Value = Me.ComboBox1 And _ c.Offset(0, -1).Value = Me.ComboBox2 Then _ d(c.Offset(0, 1).Value) = "" Next c Me.ComboBox3.List = d.keys Me.ComboBox3.ListIndex = -1 End Sub Private Sub b_validation_Click() If Me.ComboBox1 <> "" Then ActiveCell.Offset(0, 2).Value = Me.ComboBox1.Value If Me.ComboBox2 <> "" Then ActiveCell.Value = Me.ComboBox2.Value If Me.ComboBox3 <> "" Then ActiveCell.Offset(0, 4).Value = Me.ComboBox3.Value Unload Me End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect(Target, Sheet1.Range("b8:b200")) Is Nothing Then UserForm1.Show End If End Sub All.BOQ V2.xlsm

جرب هدا Sub SUMIF() Dim WS As Worksheet: Set WS = Sheets("كشف حساب") Dim sum As Double, Cnt As Long WS.[Y1] = CDate(Me.DateMini) Cnt = 0: sum1 = 0: sum2 = 0 On Error Resume Next With ListBox1 For R = 0 To .ListCount - 1 Cnt = Cnt + 1 sum1 = sum1 + .List(R, 10) sum2 = sum2 + .List(R, 11) Next R End With Me.S.Caption = Cnt TextBox3.Value = Format(sum1, "#,##00.00"): TextBox2.Value = Format(sum2, "#,##00.00") tb = sum1 - sum2 TextBox1.Value = Format(tb, "#,##00.00") tb1 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!G4:G100000,'" & WS.Name & _ "'!C4:C100000,{""مبيعات"";""قيد""},'" & WS.Name & "'!B4:B100000,""<=""&'" & WS.Name & "'!Y1))") tb2 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!H4:H100000,'" & WS.Name & _ "'!C4:C100000,{""مردودات مبيعات"";""سند قيد"";""سند قبض""},'" & WS.Name & "'!B4:B100000,""<=""&'" & WS.Name & "'!Y1))") result = tb1 - tb2 Me.Text_count.Value = Format(result, "#,##00.00") End Sub Copy of كشف حساب عميل V2.xlsm

الحل عن طريق VBA وليس معادلة إدراج التاريخ في راس الصفحة 1.xlsm

السلام عليكم أخي الكريم عدلت لك قليلا في نسق الملف بحيث أن أول جدول يتطابق مع باقي الجداول التالية يعني كل جدول بما فيها الأول يكون 36 سطر شامل السطر الفاضي بين الجداول وعندما تريد إضافة جدول آخر تأخذ نسخة من الثاني وليس من الأول واحرص أن يكون الفارق بين بداية أي جدول والذي يليه 36 سطر بالضبط تفضل المرفق التجميع2.xlsx

أللهم آمين وجزاكم عنا خيرا جميعا ونسأل الله أن يكون في ميزان كل شخص استفدت منه بمعلومة لاتمام هذا العمل

بالنسبة للتسلسل يمكنك استخدام الصيغة التالية مع سحبها للاسفل بعد حدف كود ترقيم الصفوف من حدث ورقة 1 =IF(C9>0,SUBTOTAL(3,$C$9:C9),"") اما بخصوص تنسيق اعمدة الروابط اظن انه من الافضل ربط الكود مع زر يمكنك استخدامه مثلا بعد الانتهاء من نسخ جميع الروابط على العمودين جرب هدا Function tmp(Cnt As String) As Boolean Dim Request As Object Dim rc As Variant On Error GoTo EndNow Set Request = CreateObject("WinHttp.WinHttpRequest.5.1") With Request .Open "GET", Cnt, False .Send rc = .StatusText End With Set Request = Nothing If rc = "OK" Then tmp = True Exit Function EndNow: End Function Sub add_Hyperlinks() Application.ScreenUpdating = False Set WS = Sheets("Sheet1") Dim c As Excel.Range, Cnt As String, r As Excel.Range Dim a As Range, b As Range, Rng As Range lr = WS.Columns("i:j").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = WS.Range("i9:i" & lr): Set b = WS.Range("j9:j" & lr): Set Rng = Union(a, b) For Each c In a If c > "" Then c.Select Debug.Print c.Value Cnt = Trim(CStr(c.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=c, Address:=Cnt, TextToDisplay:="رابط اليوتيوب" End If Next c For Each r In b If r > "" Then r.Select Debug.Print r.Value Cnt = Trim(CStr(r.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=r, Address:=Cnt, TextToDisplay:="رابط الفيسبوك" End If Next r With Rng .Font.Color = RGB(0, 0, 255) .Font.Underline = xlUnderlineStyleNone .Font.Bold = True .Font.Name = "Calibri" .Font.Size = 16 End With Application.ScreenUpdating = True End Sub 14-7-2024 V2.xlsm

بارك الله فيكم.