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

السلام عليكم ورحمة الله وبركاته اقدم هدية متواضعة لكم تصريح دخول للبرنامج الرقم السري 12345 تصريح دخول.accdb

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

تفضل- تم عمل معادلة جلب جميع الأصناف المدخلة في الشيت الإجمالى.xlsm التفصيلى.xlsx

تفضل دالة نقل بيانات.xlsm

بارك الله فيك استاذ . @ازهر عبد العزيز مسافر حتى الان اجيب من الموبايل .... أشكرك ...

وعليكم السلام-بارك الله فيك وجزاك الله كل خير

اهلا بك في المنتدى تفضل الإجمالى.xlsm التفصيلى.xlsx

وعليكم السلام-لك ما طلبت توزيع.xlsm

وعليكم السلام-كان عليك من البداية استخدام خاصية البحث فى المنتدى-فهنا العديد من الموضوعات التى تخص طلبك ومنها : https://www.officena.net/ib/topic/29892-توزيع-الأقساط-و-متابعة-سدادها-بـ-excel/?tab=comments#comment-148900 https://www.officena.net/ib/topic/89374-برنامج-تسجيل-الاقساط-بشكل-اوتوماتيك-اهداء-لكم/?tab=comments#comment-577703 https://www.officena.net/ib/topic/60753-برنامج-لإدارة-الأقساط/?tab=comments#comment-390838 https://www.officena.net/ib/topic/69314-معادلة-احتساب-عدد-الاقساط-مرتبط-بالمبلغ-المستحق-الكلي/?tab=comments#comment-451242 https://www.officena.net/ib/topic/69787-برنامج-العطاء-للتقسيط-الخامس-المجاني-قريبا/?tab=comments#comment-453851 https://www.officena.net/ib/topic/13020-برنامج-التقسيط-للأفراد-والمؤسسات/?tab=comments#comment-55880 https://www.officena.net/ib/topic/89184-برنامج-الاول-للاقساط/

ومن اين يتم جلب تواريخ هذه المناسبات -لابد من معرفتها مسبقا ووضعها فى الملف ؟!!!

السلام عليكم 🙂 المنتدى مليئ بمختلف المواضيع ، لهذا السبب فإننا ننصح بإستخدام خاصية البحث ، قبل وضع سؤال جديد ، فهناك احتمال كبير بوجود عدة اجابات لسؤالك 🙂 وبطبيعة الحال ، فهناك العديد من المواضيع القديمة ، والتي قد نستفيد منها بطريقة او اخرى. واذا اردنا ان نسأل في موضوع قديم ، فيجب ان نأخذ رابط ذلك الموضوع ، ونعمل موضوع جديد نضع فيه سؤالنا ، ونشير الى ذلك الرابط القديم 🙂 واذا اردنا ان نشكر صاحب الموضوع ، فممكن بالنقر على ايقونة الشكر: ورجاء عدم وضع ملاحظة/طلب تعديل/سؤال جديد في موضع قديم 🙂 جعفر

وهذه النتيجة النهائية بفضل الله تعالى ثم فضل استاذى الجليل ومعلمى القدير و والدى الجبيب الاستاذ @jjafferr وتدلل يا استاذ @Barna وهى بضاعتكم نردها ونعبدها اليكم بحلتها الجديدة تم التعديل على الاكواد لاختزالها Barna ( Export to Word ).accdb

اتفضل - تم حمل ملف الورد داخل القاعدة يمكن تغييره حسبما يناسبك - يتم عمل تحميل الملف اليا دون ادنى تدخل من المستخدم - تم اختزال الأكواد بطريقة ولا اروع أتوجه بكل الشكر والتقدير والعرفان بالجميل لاستاذى الجليل و معلمى القدير وملهمى و والدى الحبيب الاستاذ @jjafferr بفضل الله تعالى ثم استاذى تم حل مشكلة الدوران على كل السجلات لتصدير بياناتهم دفعة واحدة للاستاذ jjafferr Export to Word.accdb

وعليكم السلام -بارك الله فيك أستاذ سليم وزادك الله من فضله وهذا حل اخر بمعادلات المصفوفة لإثراء الموضوع بحث فى جدول.xlsx

جرب هذا الماكرو Option Explicit Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_Please() '========================== Dim Source_Sh As Worksheet Dim Target_Sh As Worksheet Dim LRS%, LRT%, RG_S As Range, RG_T As Range Dim cel As Range, My_adrs As Range '========================== Set Source_Sh = Sheets("DATA") Set Target_Sh = Sheets("TAB") LRS = Source_Sh.Cells(Rows.Count, 2).End(3).Row LRT = Target_Sh.Cells(Rows.Count, 3).End(3).Row Set RG_S = Source_Sh.Range("b3:M" & LRS) Set RG_T = Target_Sh.Range("C4:E" & LRT) Target_Sh.Range("F4:H" & LRT).ClearContents On Error Resume Next For Each cel In RG_T On Error Resume Next Set My_adrs = RG_S.Find(cel, lookat:=1) On Error GoTo 0 If Not My_adrs Is Nothing Then cel.Offset(, 3) = Source_Sh.Cells(My_adrs.Row, 2) End If Next End Sub الملف مرفق ب جدول - Copy.xlsm

تفضل يا سيدي 🙂 Private Sub BtnAllRcrd_Click() 'On Error GoTo ErrHandler On Error Resume Next Dim rs As DAO.Recordset Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") Set rs = CurrentDb.OpenRecordset("Table1") If Not rs.EOF Then rs.MoveFirst Do Until rs.EOF LWordDocOriginal = CurrentProject.Path & "\WordDoc.Doc" ' LWordDocSaveAs = CurrentProject.Path & "\" & rs!Fullname & "_Doc.Doc" ' FileCopy LWordDocOriginal, LWordDocSaveAs ' LWordDoc.Documents.Open CurrentProject.Path & "\" & rs!Fullname & "_Doc.Doc" LWordDoc.Documents.Open LWordDocOriginal LWordDoc.Visible = False LWordDoc.ActiveDocument.Bookmarks("fname").Select LWordDoc.Selection.InsertAfter Nz(rs!Fullname.Value, "") LWordDoc.ActiveDocument.Bookmarks("Civ").Select LWordDoc.Selection.InsertAfter Nz(rs!CivilNo.Value, "") LWordDoc.ActiveDocument.Bookmarks("Nat").Select LWordDoc.Selection.InsertAfter Nz(rs!Nationality.Value, "") LWordDoc.ActiveDocument.Bookmarks("Rate").Select LWordDoc.Selection.InsertAfter Nz(rs!Rate.Value, "") LWordDoc.ActiveDocument.Bookmarks("Chin").Select LWordDoc.Selection.InsertAfter Nz(rs!CheckIn.Value, "") LWordDoc.ActiveDocument.Bookmarks("Chout").Select LWordDoc.Selection.InsertAfter Nz(rs!CheckOut.Value, "") LWordDoc.ActiveDocument.Bookmarks("Pr").Select LWordDoc.Selection.InsertAfter Nz(rs!Price.Value, "") LWordDoc.ActiveDocument.SaveAs (CurrentProject.Path & "\" & rs!Fullname & "_Doc.Doc") rs.MoveNext Loop 'LWordDoc.Application.Documents(rs!Fullname & "_Doc.Doc").Save 'LWordDoc.Quit 'LWordDoc.ActiveDocument.SaveAs (rs!Fullname & "_Doc.Doc") LWordDoc.Quit Set LWordDoc = Nothing 'ErrHandler: ' If Err.Number = 3021 Then Resume Next End Sub جعفر

اعجبني وما بعرف مين صممه حكمة اليوم.accdb

ما ادري شو معني كلامك ؟ نحن نشجع البحث في المواضيع القديمة ، والبحث عن اجابات حديثة تحتاج الى من يرد عليها ، من الاعضاء المتواجدين في المنتدى الآن 🙂 ولكن لا ضمان من وجود الاعضاء القدامى اصحاب المواضيع القدامى ، للرد على سؤالك. جعفر

شغلت البرنامج الأن ويعمل معي .... انظر Dim X As Object On Error Resume Next Set X = CreateObject("Word.Application") X.Documents.Open CurrentProject.Path & "\المتضررين.Docx" X.Visible = True X.Activate X.ActiveDocument.Bookmarks("المعرف").Select X.Selection.InsertAfter Me.s1 X.ActiveDocument.Bookmarks("الاسم").Select X.Selection.InsertAfter Me.s2.Value X.ActiveDocument.Bookmarks("العنوان").Select X.Selection.InsertAfter Me.s3.Value X.ActiveDocument.Bookmarks("رقم_الهاتف").Select X.Selection.InsertAfter Me.s5.Value هذا هو الكود ..... طبق الشرح على ملف لديك .... يجب أن تكون القاعدة وملف الوورد في نقس المكان

تابع الشرح ..... قبل الشرح أود التأكيد على نقطة عند كتابة المسميات أكتبها بالانجليزي ومتلاصق مثل Fullname أو Full_name بالصور : هل استطعت فتح الملف ؟؟؟؟؟؟

امكن المشكلة من ملف الضغط لديك غير محدث .... لكن تفضل الملفين بدون ضفغط المتضررين.docx بيانات.accdb

وعليكم السلام .... فتح القاعدة أم ملف الضغط

استبدل هذا السطر في الكود R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row بهذا R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7"),Lookat:=Xlwhole).Row Xlwhole هنا حرف الـــ L باللغة الانكليزية وليس رقم 1 اذا كان هذا الجواب الكود يفي بالغرض اضغط على افضل اجابة لإغلاق الموضوع

انظر المرفق ..... تطبيق.rar

انا اقصد المرفق الموجود في بداية الموضوع أخي هل أعمل على التعديل عليه وأنت تنقله لملفك الخاص ؟؟؟؟

هل النموذج الموجود في بداية الموضوع يمثل نموذجك الحقيقي ...... حتي احاول العمل عليه

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

تم ازالة بعض الخلايا المدمجة لحسن عمل الكود مجرد ان تدخل الاسم او الرقم يقوم الكود بعمله واذا كان هناك خطأ يعطيك اشعاراً بذلك الكود Option Explicit Private source_sh As Worksheet Private Target_sh As Worksheet Private Last_row% Private RG_Source As Range Private R1% Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_By_name() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D8"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA nOT FOUND": Exit Sub Else With Target_sh .Range("C12") = .Range("D7") .Range("D8") = source_sh.Cells(R1, "C") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem ------------------------------------------- Sub Get_Data_By_Index() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D7"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(2).Find(Target_sh.Range("D8"), lookat:=xlWhole).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA NOT FOUND": Exit Sub Else With Target_sh .Range("D7") = source_sh.Cells(R1, "B") .Range("C12") = .Range("D7") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem +++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Count = 1 Then Select Case Target.Address Case "$D$7": Get_Data_By_name Case "$D$8": Get_Data_By_Index End Select End If Application.EnableEvents = True End Sub Archive2019.xlsm

اتفضل اخى الحبيب الملف لعله يفى بالغرض ولكن بتعديل بسيط فى الشيت حتى يكون البحث بالاسم او بالرقم من خلال خلية واحدة نسخة من ارشيف2019.xlsx

جرب هذا الملف اعتذر عن ادراج الماكرو بسبب البطء الشديد للنت AUTO_SHOW_HIDE.xlsm

جرب هذا الماكرو Option Explicit Sub Verify_data() With Sheets("ورقة1") Dim my_rg As Range Dim i% Set my_rg = Range("A2", Range("M1").End(4)) For i = 1 To my_rg.Rows.Count If my_rg.Cells(i, 2) = False Then _ my_rg.Cells(i, 7).Resize(, 7) = 0 Next End With End Sub الملف مرفق tajriba.xlsm

وعليكم السلام-اهلا بك فى المنتدى لابد من رفع ملف وشرح المطلوب عليه بكل دقة حتى تتم المساعدة

وهو ده بالفعل الموجود بالملف

يمكنك وضع السطر الأول في بداية الكود الذى يسبب اهتزاز الشاشة والسطر الأخر في نهاية نفس الكود

تفضل لك ما طلبت عدد الأيام المتبقية على المناسبات.xlsm

الحمد لله رب العالمين .... الذي جعل لي اخوة امثالكم بارك الله فيك اخي @jjafferr واخي @ابا جودى اولا لكتابة الكود واعادة صياغتة بهذه الصورة الجميلة وثانيا انا استفدت من المناقشات منذ بداية الموضوعين ... فلكم كل الاحترام والتقدير ... 🥀

نعم يمكنك نقل ازار التحكم الى نماذجك طبعا لازم تكون الوحدات النمطية موجود في برنامجك ولازم اضافة أسماء النماذج بالجدول Frm Ability لم يستجد أي جديد ::بالتوفيق::

@ابا جودى فقط هنا يكون التعديل @ابا جودى

أستاذ @kanory افتقدك ان شاء الله تكون بخير

شكرا استاذ عبد اللطيف على المجهود

السلام عليكم قوقل شيت لا يتعامل مع VBA الماكرو ولكن يتعامل مع المعادلات فقط هذه مساعدة يمكنك أدخال البيانات ومطالعة النتيجة في الشيت الثاني جربه مع قوقل شيت تحياتي tajriba1.xlsm

تحديث يوم السبت ، 13 / 07 / 2019 م الموافق 10 ذو القعدة 1440 هـ تم إجراء التالي : إضافة نموذج ضبط المصنع . إضافة نموذج النسخة الاحتياطية . تنسيقات ومميزات أخرى . تصحيح بعض الأخطاء . بالتوفيق يمكنك تغيير اسم المستخدم من نموذج البيانات الأساسية من حقل "مدير الؤسسة" أخوكم صالح عبدالله البريكان أبو آمنة ‏‏BuySal19_v04.rar

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

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

ما قصرت أستاذ @qassim-t بالعكس انت خليت للموضوع طعم وجمالية بالاخص مع افكارك الجميلة

لم أفهم السؤال الذي أفهمه أن الطالب المتخرج أو المنقول يحذف من النظام المدرسي كما هو معمول لدينا ولا يحتفظ به في قاعدة المدرسة فلا علاقة للمدرسة به

تفضل اخى الكريم بنفس معادلة الأستاذ إبراهيم بعد تعديل بسيط جدا =IF(C2="","",IF(MID(REPLACE(C2,1,LEN("فاتورة بيع"),""),1,3)=" AC"," ابواب ",IF(MID(REPLACE(C2,1,LEN("فاتورة بيع"),""),1,3)=" CH","كابينات",IF(MID(REPLACE(C2,1,LEN("فاتورة بيع"),""),1,3)=" YK","سطح ","متفرقة")))) استخراج الصنف.xlsm

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

مشكور أستاذ محمد وزادك الله من فضله

سلمت يداك اخي فكرة ممتازه