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

تفضل أخي الكريم الدرجه الأكبر.xlsx

الدرجه الأكبر.xlsx

كنت ناسيها ، تم الاستفادة من خاصية Tag

وعليكم السلام أخي TQTHAMI 🙂 شكرا لك على دعواتك الطيبة ، وتقبل الله منا ومنك 🤲 تم التنفيذ ولله الحمد .. (ولكن بشرط أن تكون النماذج مفتوحة أثناء التغيير ) وهذه هي الدالة المستخدمة : Public Sub ChangeBtnPic(PicNum As Integer, BtnTag As Integer) On Error Resume Next Dim Frm As Form, ctl As Control For Each Frm In Access.Forms If CurrentProject.AllForms(Frm.Name).IsLoaded Then For Each ctl In Frm.Controls If ctl.ControlType = acCommandButton Then If ctl.Tag = BtnTag Then ctl.Picture = PicBt & PicNum & ".bmp" End If End If Next ctl End If Next Frm End Sub icon - Moosak.rar

وعليكم السلام ورحمة الله وبركاته أخي حمدي 🙂 تفضل هذا هو التعديل : If MsgBox("هل تريد الارسال بدون مرفق؟", vbYesNo + vbExclamation, "تنبيه!") = vbNo Then If Len(Me.attach & "") = 0 Then: MsgBox "لايمكن العثور على المرفق", vbOKOnly + vbCritical: End If Len(Dir(Me.attach, vbDirectory)) = 0 Then MsgBox "لايمكن العثور على المرفق", vbOKOnly + vbCritical: End Else .AddAttachment Me.attach End If End If

طيب حسب ما فهمت ................ انشئ نموذج وضع في زر وفي حدث الزر ضع هذه الشيفرة :::: Dim xx As String xx = InputBox("ادخل النسبة ", "حدد ") DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE Table1 SET Table1.Field1 = [field1]*" & xx & ";" DoCmd.SetWarnings True

جرب الآن والتعديل في الآتي: 'rst.Sort = "LVLno,Parent,Code" 'ترتيب نصي rst.Sort = "LVLno,CLng(Parent),CLng(Code)" 'ترتيب رقمي وهنا أيضا: For Each nodX In TreeView6.Nodes nodX.EnsureVisible nodX.Expanded = False 'nodX.Sorted = True 'لا تستخدم هذا السطر لأنه سيخرب الترتيب السابق nodX.Bold = True nodX.Selected = False Next MZ_SUB 05.rar

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

اتفضل ملفك بعد التعديل GSTION.accdb

تم التعديل على جدول الموضوعات بتبديل اسم حقلين No1 ، No2 وتم إضافة حقل Error لمعرفة السجلات التي فشلت في الإضافة. التعديل على الأسماء لتساعدني في التركيز ، وأنصح دائما باستخدام اسماء تدل على معناها. كذلك قمت بتقليص طول الحقلين أعلاه إلى 50 رمز وأنصح بتقليصه من طرفكم بعد التأكد من أقصى طول مطلوب. جدول TAB_Subject_X يجب تبديل حقل ID من AutoNumber إلى Number العلاقات بين الجداول تحتاج إلى إعادة دراسة استعن بغيري 🙂 . تم تصحيح الكود ليصبح كالتالي: Set rst = dbs.OpenRecordset("TAB_Subject", dbOpenDynaset) rst.Sort = "LVLno,Parent,Code" 'جديد Set rst = rst.OpenRecordset 'جديد Set nodX = TreeView6.Nodes.Add(, , "A", "الموضوعات") With rst Do While Not .EOF Err.Clear Set nodX = TreeView6.Nodes.Add("A" & CStr(Nz(!Parent, "")), _ tvwChild, "A" & CStr(!Code), _ CStr(!Code) & ":" & !Sname) 'مؤقتا حتى يتم التأكد من سلامة كل البيانات ------------ .Edit !Error = Err.Number <> 0 .Update '----------------------------------------------------- 'If Err.Number = 0 Then nodX.EnsureVisible 'هذا السطر يسبب بطء شديد .MoveNext Loop 'مؤقتا حتى يتم التأكد من سلامة كل البيانات ------------ MsgBox "إجمالي السجلات: " & .RecordCount & vbCrLf & _ "السجلات المضافة: " & TreeView6.Nodes.Count & vbCrLf & _ "السجلات الفاشلة: " & .RecordCount - TreeView6.Nodes.Count _ & vbCrLf & vbCrLf & _ "راجع جدول الموضوعات حقل Error" '----------------------------------------------------- End With rst.Close MZ_SUB 04b.rar

وعليكم السلام ورحمة الله وبركاته اتفضل طلبك تم من خلال التنسيق الشرطى ارسال.mdb

وعليكم السلام ورحمة الله وبركاته 🙂 ولا واحد من القائمة اعلاه موجود في ملفك ، فلا نستطيع مساعدتك !! ويجب عليك اعادة النظر في جدولك ، ويجب تقسيمه الى جدولين او ثلاثة تحتوي جميعها على الحقل EmpCode ، ثم ربط الجداول بحقل EmpCode في استعلام ، وعرض النتائج التي تريدها 🙂 وإلا : 1. جدولك سيكون بطيء لما تصبح البيانات التي به تتعدى 10 الآف سجل ، 2. لن يمكنك ادخال بيانات في جميع الحقول ، فمجموع حروف اي سجل في جدول لا تتعدى 4000 حرف ، واليك هذه المعلومة من مايكروسوفت: . من اعدادات الجدول هنا: . جعفر

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

وعليكم السلام.. المفروض في سؤالك ان تحتفظ بالرقم المتشابه الاول ولنفرض اسم الحقل ID في الجدول1 1-أعمل جدول2 لالحاق البيانات من الجدول1 الى الجدول2 حتى تحتفظ بالسجلات الاصلية ..حيث تعمل استعلام الحاق بذلك نسميه App_Q 2- اعمل استعلام من الجدول1 ولنسميه مثلا DUPE_Query 3- نعمل موديول لحذف الارقام المكررة بهذا الشكل Sub DUPE_REMOVAL() 'مسح الارقام المكررة من الجدول Dim db As DAO.Database Dim rst As DAO.Recordset Dim ingID As Long Dim ingIDLast As Long Set db = CurrentDb Set rst = db.OpenRecordset("DUPE_Query") ingIDLast = 0 Do Until rst.EOF ingID = rst!ID If ingID = ingIDLast Then rst.Delete End If rst.MoveNext ingIDLast = ingID Loop rst.Close Set rst = Nothing Set db = Nothing End Sub 4- اعمل نموذج مع كمبوبوكس مصدر الصف له من الاستعلام DUPE_Query 5- في حدث عند التحميل للنموذج ضع الكود التالي DoCmd.SetWarnings False DoCmd.OpenQuery "App_Q" DoCmd.SetWarnings True Call DUPE_REMOVAL

نسخة تضم تعديلي وتعديلك. MZ_SUB 10.rar

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

جزاك الله خيرا

وهذه مساهمة إضافية مني awad77_03.xlsm

وعليكم السلام 🙂 جرب الآن .. If Len(Me.attach & "") <> 0 Then If Len(Dir(Me.attach, vbDirectory)) = 0 Then MsgBox "لايمكن العثور على المرفق", vbOKOnly + vbCritical: End Else .AddAttachment Me.attach GoTo Contenue End If End If If MsgBox("هل تريد الارسال بدون مرفق؟", vbYesNo + vbExclamation, "تنبيه!") = vbYes Then GoTo Contenue Else If Len(Me.attach & "") = 0 Then: MsgBox "يرجى إضافة المرفق", vbOKOnly + vbCritical: End If Len(Dir(Me.attach, vbDirectory)) = 0 Then MsgBox "لايمكن العثور على المرفق", vbOKOnly + vbCritical: End Else .AddAttachment Me.attach End If End If Contenue: flds("urn:schemas:mailheader:content-type") = "multipart/alternative" flds.Update .Send ارسال Moosak.rar

علشان تعمل هذي الخطوة .. لازم تحفظ القيم في جدول .. ولما يفتح أي نموذج ياخذ القيم من الجدول .. وهذي لحالها قصة ثانية 🙂 وأترك موضوعها للشباب .. لأني بكون مشغول خلال الفترة القادمة 😉🌹

تفضل اخي =STXT(D21;TROUVE("DU";D21)+2;NBCAR(D21)) او =DROITE(D21;10) Facture3 OFFICENA.xlsm

طيب جرب هذا ................... Dim xx As String xx = InputBox("ادخل النسبة ", "حدد ") xx = Replace(xx, "%", "") DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE Table1 SET Table1.Field1 = [field1]*" & xx & ";" DoCmd.SetWarnings True

السلام عليكم ورحمة الله وبركاتة اخي الكريم Moosak انت رائع بكل معنى الكلمة هذا تماما ما اريده أولا: بيض الله وجهك يوم تبيض وجوه وأظلك في ظله يوم لا إلا ظله وجعلك مفاتيح للخير مغاليق للشر ورزقك حجاً مبرور وتجارةً لن تبور إن شاء الله العزيز الحكيم. ثانيا : مثال رائع واجابة موفقة اكثر من ما طلبت واذا تكرمت واكملت معروفك وجعلته يعمل على كل النماذج يعني يكون التطبيق ليس على هذا النموذج فقط بل في كافة النماذج عندها سيكون لك فضل المعلم على الطالب تحياتي وبأنتظار ردك icon.rar

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

وعليكم السلام ورحمه الله وبركاته مشاركه مع اخى واستاذى محمد @Barna جزاه الله خيرا اتفضل اخى حسين @husseinharby تم انشاء وحده نمطيه واستدعائها بالاستعلام ان شاء الله تروق لك بالتوفيق Database11.accdb

كل الشكر والتقدير لشخصكم الكريم

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

اتفضل للعلم انا ما غيرت شئ بس فتحت التنسيق الشرطى فى وضع التعديل وقمت بالاغلاق دون التعديل على اى شئ واشتغل كل شئ حقيقة لا ادرى سبب المشكلة ارسال (2).rar

اتفضل تم اضافه Me.Refresh بالتوفيق taxxxx_1(1).accdb

ولا يهمك اخى اتفضل بالتوفيق taxxxx_1.accdb

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

وعليكم السلام ورحمة الله وبركاته جرب الآن حسب فهمي المتواضع للشرح : 🙂 icon - Moosak.rar

تفضل اخي ضع هده المعادلة في الخلية B2 وسحبها لاخر صف لديك للحصول على اسماء المشرفين ليوم الأحد وبنفس الطريقة على كل ايام الأسبوع مع استبدال إسم العمود داخل المعادلة. بالتوفيق =SIERREUR(INDEX('الزيارات بأسماء المشرفين'!$A$2:$A$11;EQUIV(A2;'الزيارات بأسماء المشرفين'!$B$2:$B$11;0);EQUIV($B$1;'الزيارات بأسماء المشرفين'!$B$1:$B$1;0));"") تجربة الزيارات.xlsx

جربت الملف الأخير؟

السلام عليكم 🙂 انا استخدم هذه الوحدة النمطية: Option Compare Database Option Explicit '--------------------------------------------------------------------------------------- ' Procedure : EnableArrowsScroll ' Author : Daniel Pineault, CARDA Consultants Inc. ' Website : http://www.cardaconsultants.com ' Purpose : Enable using the up and down arrows to move between records on a ' continuous form ' Req'd Refs: None ' The Form's Key Preview property must be set to True for this code to work. ' ' Input Variables: ' ~~~~~~~~~~~~~~~~ ' iKeyCode : Keycode from the source form from the KeyDown event ' frm : form object to apply the new behavior to ' ' Usage: ' ~~~~~~ ' KeyCode = EnableArrowsScroll(KeyCode, Me) 'This is placed in the KeyDown event ' 'Dont forget to set the Key Preview property to Yes ' ' Revision History: ' Rev Date(yyyy/mm/dd) Description ' ************************************************************************************** ' 1 2011-07-07 Initial Release ' 2 2017-04-08 Added DefaultView check '--------------------------------------------------------------------------------------- Public Function EnableArrowsScroll(ByVal iKeyCode As Integer, frm As Access.Form) As Integer On Error GoTo Error_Handler If frm.DefaultView = 1 Then 'Only process for Continuous forms Select Case iKeyCode Case vbKeyDown ' If CurrentRecord <> RecordsetClone.RecordCount Then 'Restrict to existing records If frm.NewRecord = False Then 'Allow going to new record for data entry DoCmd.GoToRecord , , acNext End If EnableArrowsScroll = 0 Case vbKeyUp If frm.CurrentRecord <> 1 Then DoCmd.GoToRecord , , acPrevious End If EnableArrowsScroll = 0 Case Else EnableArrowsScroll = iKeyCode End Select Else EnableArrowsScroll = iKeyCode End If Error_Handler_Exit: On Error Resume Next If Not frm Is Nothing Then Set frm = Nothing Exit Function Error_Handler: If Err.Number <> 2105 Then MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: EnableArrowsScroll" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occurred!" End If Resume Error_Handler_Exit End Function . وتناديها على حدث "الزر الاسفل" للنموذج ، هكذا Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error GoTo Error_Handler KeyCode = EnableArrowsScroll(KeyCode, Me) Error_Handler_Exit: On Error Resume Next Exit Sub Error_Handler: MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Form_KeyDown" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occurred!" Resume Error_Handler_Exit End Sub . جعفر 1532.UseArrow.mdb.zip

لقد قمت بالبحث عن أصل الكود ووجدته على أحد المواقع الأجنبية ووجدت دالة GetTickCount التي لو كانت موجودة ضمن مثال السائل لانتهى الموضوع من "زمان" وانتهت معه هذه المعاناة. حتى لا يتوه السائل أضفت صناديق بنفس الأسماء وبدلت أسماء باقي المكونات أيضا. أعتقد الآن الموضوع منتهي ولا حاجة لانتظار الإجابة. نسخة مع التحية للأستاذ @jjafferr StopwatchTimer_01.rar

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

وهذه هي الدالة التي ذكرتها لك بشكل مبدأي : Public Function ClassAndSectionAsNumber(strClass As String, strSection As String) As String Dim ClassNumber, SectionNumber Select Case strClass Case Is = "الأول الإبتدائي": ClassNumber = 1 Case Is = "الثاني الإبتدائي": ClassNumber = 2 Case Is = "الثالث الإبتدائي": ClassNumber = 3 Case Is = "الرابع الإبتدائي": ClassNumber = 4 Case Is = "الخامس الإبتدائي": ClassNumber = 5 Case Is = "السادس الإبتدائي": ClassNumber = 6 Case Else: ClassNumber = "Undefined" End Select Select Case strSection Case Is = "أول": SectionNumber = 1 Case Is = "ثاني": SectionNumber = 2 Case Is = "ثالث": SectionNumber = 3 Case Is = "رابع": SectionNumber = 4 Case Is = "خامس": SectionNumber = 5 Case Is = "سادس": SectionNumber = 6 Case Else: SectionNumber = "Undefined" End Select ClassAndSectionAsNumber = "(" & SectionNumber & "/" & ClassNumber & ")" End Function ويمكنك تطبيقها بكتابة اسم الدالة ثم الفصل ثم الشعبة وستعطيك النتيجة النهائية هكذا : 🙂 (1): ClassAndSectionAsNumber("الثاني الإبتدائي","خامس") النتيجة: (5/2) -------------------------------------------------------------------------- أو هكذا : (2) ClassAndSectionAsNumber(Me.ClassTxt,Me.SectionTxt)

طريقة اخوي ابوبسملة صحيحة اذا كان الحقلين D و M ارقام ، وإلا اليك الطريقة اللي في الرابط اعلاه : dim myWhere as string myWhere="[D] =" & rs!degree1 'اذا الحقل رقم 'myWhere="[D] ='" & rs!degree1 & "'" 'اذا الحقل نص myWhere= myWhere & " and " myWhere=myWhere & "[M]=" & rs!step1 'اذا الحقل رقم 'myWhere=myWhere & "[M]='" & rs!step1 & "'" 'اذا الحقل نص rs!NewAsmi = DLookup("[R]", "Ratib_Tb", myWhere) . وبهذه البساطة تقدر تعمل الامر Dlookup بدون اخطاء 🙂 وطبعا اذا استخدمت نموذج ولد بلادك موسى في هذا الموضوع ، فهو تلقائيا يعرف العلوم ويضبط امورك 🙂 جعفر

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

اهلا بحضرتك اشتاقت اليكم نفسى كثيرا هذا تصوير للمرفق

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ..اليك الكود التالي لاستدعاء الفواتير بشرط رقم الفاتورة .مع اضافة ظهور اشعار بوجودها مسبقا في حالة كتابة رقمها في جدول الادخال كما جاء في طلبك . الكود لم ارفعه هنا قد تمت اضافته في حدث شيت ( مستند قيد) وان شاء الله نكون انتهينا من الخطوة الثانية. Sub Find_MH() Set Sh1 = Worksheets("مستند قيد") Set sh2 = Worksheets("اليومية العامه") Dim lastrow As Long Dim Mh As Long Dim iCont As Integer Dim r As Integer Dim c As Integer Dim MH2 As Worksheet Dim MH3 As Worksheet Dim Trouve As Range Application.ScreenUpdating = False If Len(Range("d5").Value) = 0 Then ' '<--التحقق من وجود قيمة في خلية البحث MsgBox "المرجوا ادخال رقم الفاتورة" Exit Sub End If With Sheets("اليومية العامه") 'في عمود (D) شيت الفواتير اليومية'<--- التحقق من وجود رقم الفاتورة Set Trouve = .Range("d:d").Find(what:=Sheet1.Range("d5"), LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then MsgBox (" !!!رقم الفاتورة غير مسجل مسبقا") Exit Sub Else End If End With MH1 = Sh1.Range("D5").Value ' '<--- في حالة تحقق الشرط With sh2 lastrow = .Cells(.Rows.Count, "b").End(xlUp).Row '+ 1 Mh = WorksheetFunction.Match(MH1, .Range("D5:D" & lastrow), 0) + 4 iCont = WorksheetFunction.CountIf(.Range("D5:D" & lastrow), MH1) End With X = 3 For c = 2 To 2 Sh1.Cells(X, 4) = sh2.Cells(Mh, c).Value ' '<---عمود D ( التاريخ - رقم الفاتورة _ الشركة_ ' Sh1.Cells(X + 1, 4) = sh2.Cells(Mh, c + 1).Value 'sh1.Cells(X + 3, 4) = sh2.Cells(Mh, c + 3).Value ' '<--- تم تعويضها بمعادلة '''=SI(D3="";"";CONCATENER(TEXTE($D$5;"0##########");" - ";$D$4;" - "&TEXTE('مستند قيد'!D3;"mm-yyyy"))) Sh1.Cells(X + 1, 6) = sh2.Cells(Mh, c + 15).Value ' '<---عمود F Sh1.Cells(X + 3, 6) = sh2.Cells(Mh, c + 17).Value Sh1.Cells(X + 2, 6) = sh2.Cells(Mh, c + 16).Value Sh1.Cells(3, 6) = sh2.Cells(Mh, c + 14).Value Sh1.Cells(3, 2) = sh2.Cells(Mh, c + 10).Value ' '<---عمود B Sh1.Cells(4, 2) = sh2.Cells(Mh, c + 11).Value Sh1.Cells(5, 2) = sh2.Cells(Mh, c + 12).Value Sh1.Cells(6, 2) = sh2.Cells(Mh, c + 13).Value X = X + 1 Set MH2 = Worksheets("اليومية العامه") Set MH3 = Worksheets("مستند قيد") lastrow = MH2.Cells(Rows.Count, "F").End(xlUp).Row If MH2.FilterMode Then MH2.ShowAllData Worksheets("مستند قيد").Range("b9:F51").ClearContents ' '<---افراغ البيانات السابقة With MH2.Rows(6) ' '<--- تحديد رقم صف رؤؤوس الاعمدة ' '<--- تحديد عمود وجودة القيمة المبحوث عنها Row4 ___________________________________' '<--تحديد خلية البحث .AutoFilter Field:=4, Criteria1:=Worksheets("مستند قيد").Range("D5").Value ' ' <--- _____________________فلترة البيانات If MH2.Range("d6:d" & lastrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then MH2.Range("F7:J" & lastrow).SpecialCells(xlCellTypeVisible).Copy MH3.Range("b" & Rows.Count).End(3)(2) ' '<--- مكان اللصق MH3.Range("A9:G51").Borders.LineStyle = xlContinuous ' '<---تسطير الجدول End If .Parent.AutoFilterMode = False ' '<---الغاء الفلترة End With Next Application.ScreenUpdating = True End Sub واليك اخي كود اضافي للترحيل من شيت الفاتورة الى شيت الفواتير اليومية ربما تحتاجه يوما ما. Sub TARHIL2() Dim LastRowF1 As Integer Dim NextRowF2 As Integer Dim RowCount As Integer Dim rngF1 As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("مستند قيد") Set Sh2 = Worksheets("اليومية العامه") Dim Arr As Variant Arr = Array([b3], [d3], [f3], [b4], [d4], [f4], [f5], [f6]) For i = 0 To 7 If Arr(i) = "" Then MsgBox "المرجوا ادخال البيانات" Arr(i).Select Exit Sub End If Next i With Sh1 NextRowF2 = Sh2.Cells(Rows.Count, 6).End(xlUp).Row + 1 If NextRowF2 < 9 Then NextRowF2 = 7 LastRowF1 = .Cells(Rows.Count, 2).End(xlUp).Row - 1 Set rngF1 = .Range(.Cells(9, "B"), .Cells(LastRowF1, "g")) RowCount = rngF1.Rows.Count Sh2.Cells(NextRowF2, "F").Resize(RowCount, rngF1.Columns.Count).Value = rngF1.Value Sh2.Cells(NextRowF2, "B").Resize(RowCount).Value = .Range("d3").Value Sh2.Cells(NextRowF2, "C").Resize(RowCount).Value = .Range("d4").Value Sh2.Cells(NextRowF2, "d").Resize(RowCount).Value = .Range("d5").Value Sh2.Cells(NextRowF2, "E").Resize(RowCount).Value = .Range("d6").Value Sh2.Cells(NextRowF2, "L").Resize(RowCount).Value = .Range("b3").Value Sh2.Cells(NextRowF2, "M").Resize(RowCount).Value = .Range("b4").Value Sh2.Cells(NextRowF2, "N").Resize(RowCount).Value = .Range("b5").Value Sh2.Cells(NextRowF2, "O").Resize(RowCount).Value = .Range("b6").Value Sh2.Cells(NextRowF2, "P").Resize(RowCount).Value = .Range("F3").Value Sh2.Cells(NextRowF2, "Q").Resize(RowCount).Value = .Range("F4").Value Sh2.Cells(NextRowF2, "R").Resize(RowCount).Value = .Range("F5").Value Sh2.Cells(NextRowF2, "S").Value = .Range("F6").Value Sh1.Range("b2").Value = Sh2.Range("d" & Rows.Count).End(xlUp).Value + 1 End With End Sub بالتوفيق. في انتظار الرد بعد التجربة . فاتورة_MH.xlsm

تفضل اخي الكريم يتم اظهار النموذج مع المجال K فقط MiniGalendar2.xlsm

وعليكم السلام عسى ان يكون ماتريده رصيد.accdb

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

أستاذي العزيز اذا تفضلت على الملف المرفق اعلاه يتم العمل مشكلتي انه عند تحديث الاستعلام احتاج كود يعمل على عمل requery للضريبة مثل حدث after_update @jjafferr

المثال اعلاه جول بسيط استاذي

لا أَيُّها القوّمُ وَيَحكُمُ هُبّوا أُسائِلُكُم وَلُا مجُيـــبُّ 😩😩😩