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

يمكن ان يكون المطلوب SABAH.xlsx

تم معالجة الأمر 1- للبحث * تعبئة احد التكست بوكسات الخضراء ( ليس الاثنين معاً) بما تريد البحث عته (مع مراعاة وجود ما تريد البحث عنه في الجدول بنفس العامود) اذا كان ما يبحث عنه موجوداً ( ولو في اكثر من صف) تظهر كل البيانات على الليست بوكس و اذا لم بكن موجوداً يتوقف الماكرو 2-للتعديل (او الحفظ من جديد) بعد اجراء عملية البحث * اضغط على اي صف من الليست بوكس (ما عدا الصف الأول العناوين) تظهر لك بيانات الصف الرقم القومي و رقم الكود (في المربعات الحضراء) يظهر لك المصروف القديم (المربع الأصفر الاول غير قابل للكتابة بداخله) ورقم الصف ( المريع الزهري) امّا المصروف الجديد عليك ان تحدده بنفسك (المربع الأصفر الثّاني) * اكتب الرقم الجديد للمصروف في المربع الأصفر الثاني * اضغط الزر "حفظ" عندها تنتقل المعلومات الى الشيت و الليست بوكس في نفس الوقت 3- الملف مرفق وعسى أن ينال الإعجاب YARA_FORM..xlsm

توضيح

تأكد من السؤال قبل طرحه اين يوجد اكثر او أقل من 5 مرات

الطباعة على وجهي الورقة يكون من خلال اعدادات الطابعة اذا كانت تدعم ذلك ومن اشهر الطابعة التي تدعم ذلك طابعة Xerox VersaLink C405 وهناك انواع اخرى ولكن هذه جربتها سابقا بالنسبة لك اذا كانت طابعتك تدعم ذلك كل المطلوب اضافة صفحة في التقرير من خلال استخدام فاصل صفحات او اي تنسيق تراه واذا كانت طابعتك لا تدعم فيكون التبديل يدوي من خلال اعدادات الصفحة قبل الطباعة تكتب 1 لطباعة الصفحة الاولى ثم تقوم بقلب الورقة واعادة طباعة التقرير ونختار الرقم 2 للتقارير المتعددة الصفحات نختار ارقام الصفحات الفردية 1-3-5-7-9-11 وبعد الطباعة نقوم بقلب الورق ونختار ارقام زوجية 2-4-6-8-10 الخ الخلاصة الطباعة على وجهي الورقة المسئول عنه الطابعة وليس اكسس تحياتي

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

1-تغيير اسم الصفحة الأولى الى Main من اجل نسح الكود بطريقة صحيحة دون مشاكل اللغة العربية 2- الماكرو اللازم عدد (2) Option Explicit Sub From_One_to_ALL() Dim sh As Worksheet Dim Itm, m% Dim Filter_Range As Range Dim AR() Application.ScreenUpdating = False Set Filter_Range = _ Sheets("Main").Range("A1").CurrentRegion m = 1 For Each sh In Sheets If sh.Name <> "Main" Then ReDim Preserve AR(1 To m) AR(m) = sh.Name m = m + 1 End If Next For Each Itm In AR Sheets(Itm).Range("A1").CurrentRegion.Clear Filter_Range.AutoFilter 1, Sheets(Itm).Name Filter_Range.SpecialCells(12).Copy _ Sheets(Itm).Range("A1") Next Application.CutCopyMode = False If Sheets("main").AutoFilterMode Then Sheets("Main").Range("A1").AutoFilter End If Erase AR Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub Clear_all() Dim sh As Worksheet For Each sh In Sheets If sh.Name <> "Main" Then sh.Range("A1").CurrentRegion.Clear End If Next End Sub الملف مرفق GROUPING_SHEETS.xlsm

تفضل التعديل اخي الكريم العقودrar.rar

تفضل اخي الكريم Private Sub city_NotInList(NewData As String, Response As Integer) Dim ctl As Control Dim strSQL As String Set ctl = Me!city If MsgBox(" اسم المدينة" & " / " & _ Me.city.Text & " / ليس ضمن القائمة هل تريد إضافته ", _ vbOKCancel, "officena") = vbOK Then Response = acDataErrAdded strSQL = "INSERT INTO tbl_city(city) VALUES('" strSQL = strSQL & NewData & "');" CurrentDb.Execute strSQL MsgBox "تمت الاضافة ", , "officena" Else Response = acDataErrContinue ctl.Undo End If End Sub school.rar تحياتي

وعليكم السلام-ابدأ بنفسك اولا فقد نبهنا كثيراً على هذا الأمر انه لا يوجد من يقوم بعمل كل هذا لك على الجاهز ... فالمنتدى تعليمى من المقام الأول وليس لتقديم البرامج الجاهزة بارك الله فيك ووفقك

اخى فى الله انى احبك فى الله حفطك الله وبارك فيك انت مش ممكن رائع رائع رائع رائع رائع رائع بارك الله فيك اختك

وعليكم السلام اخى الفاضل استخدم استعلام تحديث ثم شغل الاستعلام بالماكرو وبعدها ريكويرى UPDATE tblYesNo SET tblYesNo.[YesNo] = -1; بالتوفيق

جرب هذا الملف (نموذج عما تريد) Ken3ani.xlsx

مبارك لكم .. أخي @Khalf نفع الله بكم 🌹🌹

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

استاذي الفاضل علي بارك الله فيك علي اهتمامك قد يعجز الشكر عن تقديرى لك فجزاك الله خيرا اخي الفاضل

ماشاء الله حل سهل و ذكي و جميل كنت اود المشاركة لكني لن استطيع تقديم فكرة افضل من هذه

مشكور اخ علاء على الطريقة الناجحة... ملاحظة :يمكن دمج كودك مع الرابط في الكود الخاص ببرنامجي وبهالحالة يصبح الكود ممتاز

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم لاضافة سنة كاملة باليوم mySQL = "Select * From tbl1" Debug.Print mySQL Set rst = CurrentDb.OpenRecordset(mySQL) For i = 0 To 364 rst.AddNew rst!txtDate = DateAdd("d", i, txt_From) rst.Update Next لاضافة سنة كاملة بالشهر mySQL = "Select * From tbl1" Debug.Print mySQL Set rst = CurrentDb.OpenRecordset(mySQL) For i = 0 To 11 rst.AddNew rst!txtDate = DateAdd("m", i, txt_From) rst.Update Next db1.rar تحياتي

معي هذه الطريقة التي تشترط وجود الجداول في نفس مجلد الواجهات ضع هذه الوظيفة في موديول ثم قم باستدعائها في النموذج الافتتاحي في حدث عند التحميل Public Function connect() Dim dada Dim wrkJet0 As Workspace Dim dbs0 As DAO.Database adad = CurrentProject.Path & "\DATA.accdb" Set wrkJet0 = DBEngine.Workspaces(0) Set dbs0 = wrkJet0.OpenDatabase(adad, False, False, ";PWD=" & "PASSWORD") Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb() For Each tdf In db.TableDefs If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then On Error Resume Next tdf.Connect = ";DATABASE=" & adad tdf.RefreshLink End If Next End Function عليك تغيير كلمة PASSWORD بكلمة السر الخاصة بقاعدة بيانات الجداول ولاحظ تن قاعدة البيانات عندي اسمها Data.accdb. وعليك كتابة اسم قاعدة البيانات الخاصة بك بدلا منها اتمنى ان تكون الطريقة مفيدة لك اخوك علاء

الف مبروك استاذ خلف 🌹🌹

وعليكم السلام برنامج-التقرير-اليومي (1).rar

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

تم معالجة الامر بالنسبة لزر "حفظ " والباقي فيما بعد لضيق الوقت 1- تم تحسين مظهر اليوزر من حيث التنسيق 2- لا تتم عملية الترحيل الى الشيت الا اذا كانت كل التكست بوكسات (الرقم القومى / رقم الكود/ الاسم / المصروف) غير فارغة نظهر رسالة بعدد التكست بوكسات الفارغة 3- الكود لا يسمح بتكرار البيانات (اي بيانات مكررة يقوم الكود بحذفها على الفور 4- يمكن التنقل والعمل داخل الشيت حتى ولو كان اليوزر ظاهراً 5- جربي وهاتي رأيك YARA_uSER.xlsm

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

وعليكم السلام-تفضل وعليك فقط بدراسة المعادلة الأساسية الموجودة بالعمود K وهو عمود رقم الكود ومهمتها الأساسية جلب رقم الكود دون تكرار وستجد ان باقى المعادلات معتمدة على هذه المعادلة -بارك الله فيك =IFERROR(INDEX($B$2:$B$600,MATCH(0,INDEX(COUNTIF($K$1:K1,$B$2:$B$600),),0)),"") الفاتورة.xlsx

اللهم اغفر لي ذنوبي كلها دقها وجلها...اللهم اغفر لي ما قدمت وما أخّرت وما أعلنت وما أسررت وما أنت أعلم به مني أنت المقدّم وأنت المؤخر وأنت على كل شيء قدير...اللهم اغفر لنا الذنوب التي تهتك العصم واغفر لنا الذنوب التي تجلب النقم

اخي الكريم الواضح من كلامك انك تحتاج تحفظ مسار كل صورة في قاعدة البيانات اذا كان هذا قصدك اتفضل هذا الكود انشاء الله يفي بالغرض Dim Path As String Path = "ضع هنا مسار الملجد" Dim msg As String Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim i As Integer Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(Path) For Each objFile In objFolder.files msg = msg & vbNewLine & objFile.Path ' ضع هنا عنصر التحكم الذي سيتم حفظ المسار اليه Next objFile

!!!! ؟؟؟؟ هل الملف المرفق له علاقة أم بداية اثار الكبر أخي @jjafferr

وهذه طريقة أخرى مشاركة مع العمدة @jjafferr Sub SaveAttachmentAll(Optional FilePath) On Error Resume Next Dim Rs As DAO.Recordset, RsA As DAO.Recordset Dim NewFileName, Rc, Sn Set Rs = Me.RecordsetClone Rs.MoveFirst 'Loop throu All record Do Until Rs.EOF 'Set attachment db Set RsA = Rs("pic").Value 'Get record count If RsA.RecordCount = 0 Then Exit Sub RsA.MoveLast Rc = RsA.RecordCount RsA.MoveFirst ' Loop throu current record attachments Do Until RsA.EOF ' make Sequence if more one attachment If Rc > 1 Then Sn = RsA.AbsolutePosition 'if no file path provide, get db path If IsMissing(FilePath) Then FilePath = CurrentProject.Path & "\Images\" End If ' Make new file name NewFileName = Rs("جلوس") & Sn & "." & RsA("filetype") ' Save attached file to new file name RsA("FileData").SaveToFile FilePath & NewFileName RsA.MoveNext Loop Rs.MoveNext Loop Set Rs = Nothing Set RsA = Nothing End Sub ثم استدعيه من الزر Call SaveAttachmentAll kan.rar

السلام عليكم 🙂 هذا الكود سيحفظ لك جميع الصور الموجودة ، بغض النظر عن عدد الصور في الحقل ، احفظ هذه الوحدة النمطية كما هي : Public Function Export_Attached_Pictures(TQ_Name As String, fld_Name As String, Export_Folder_Name As String) On Error GoTo err_Export_Attached_Pictures ' TQ_Name = Table or Query Name ' fld_Name = Attachement field name ' Export_Folder_Name = where to export the picture Dim db As Database Dim rst_TQ As DAO.Recordset Dim rst_Pictures As DAO.Recordset Set db = CurrentDb ' the parent recordset. Set rst_TQ = db.OpenRecordset(TQ_Name) ' loop through it While Not rst_TQ.EOF ' the child recordset. Set rst_Pictures = rst_TQ.Fields(fld_Name).Value ' Loop through the attachments. While Not rst_Pictures.EOF ' Save current attachment to disk, with their original names rst_Pictures.Fields("FileData").SaveToFile Export_Folder_Name rst_Pictures.MoveNext Wend rst_TQ.MoveNext Wend Exit_Export_Attached_Pictures: rst_TQ.Close: Set rst_TQ = Nothing rst_Pictures.Close: Set rst_Pictures = Nothing Exit Function err_Export_Attached_Pictures: If Err.Number = 3839 Then 'file exists Resume Next ElseIf Err.Number = 91 Or Err.Number = 3420 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_Export_Attached_Pictures End If End Function . ثم نادها هكذا : لجميع صور الجدول الجدول t الحقل Pic مسار مجلد الحفظ D:\Test call Export_Attached_Pictures("t","Pic","D:\Test") لجميع صور الاستعلام الاستعلام 11 call Export_Attached_Pictures("11","Pic","D:\Test") . وفي هذا الرابط شرح لنفس الكود اعلاه ، ولكن لحفظ المرفقات ، كُلاً في مجلده : . وهنا رابط حذف المرفقات : جعفر 1256.برنامج لحفظ صور القاعدة داخل مجلد.zip

بعد اذن احي المهندس جرب هذا الملف (لك حق الاختيار الحد الادنى والاقصى) Alien.xlsx

سلمت استاذ سليم

تهمل الخلايا الفارغة و ليس المسافات (لان المسافة لا تعتبر فراغاً)

واضح جداً من اللائحة ان هناك بعض الاسماء التي تسيقها مسافات زائدة مثلا سامر في اول السطر بينما كريم قبله مسافة او ربما مسافتين ابظر بعد ازالة هذه المسافات With_2 ابجدي.xlsx

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