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

وعليكم السلام 🙂 رجاء مراعاة قوانين المنتدى بحيث يكون اسم الموضوع يدل على مضمونه 🙂 تفضل الطريقة : . وسبب اختياري هذين الحقلين من النموذجين : . هو بسبب وجود العلاقة بين الجدولين : . جعفر

حياك الله اخوي حسين 🙂 جعفر

Try his file Code_Number.xlsx

تم التعديل على الملف بالنسبة لليوزرفوم (الملف مرفق) اتبع هذه الصور لمعرفة كيفية التعامل مع اليورز الجديد ABOU_TIBA.xlsm

السلام عليكم أعتقد أن هذا الكود يعمل ولكن لم اجربه أرجو التجربة والافادة Sheets(2).RefreshAll ملاحظة: الرقم بين الاقواس هو رقم الشيت المراد تحديثه وأعتقد أن هذا الاعداد سيغنيك عن هذا

تفضل هذا الكود اخي الكريم حدد البيانات المراد تحديثها و كذلك الجداول Dim db As Database Dim sSQL As String On Error GoTo errorhandle ' الجدول الأول Set db = CurrentDb sSQL = "UPDATE Employees SET NameEmploye = '" & Text1 & "', StutesEmploye = '" & Text2 & "' WHERE [NoEmploye]=1;" db.Execute sSQL ' الجدول الثاني Set db = CurrentDb sSQL = "UPDATE LeaveRequest SET StutesEmploye = '" & Text2 & "' WHERE [NoEmploye]=1;" db.Execute sSQL MsgBox "تم تحديث الجداول بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit

يمكنك تجربة هذا الماكرو البسيط غير اسماء الشيتات بالانجليزي حتى لا يحدث خطا Sub copy() sheet1.Range("a16:b25").copy sheet2.Range("h11:i20") End Sub

اخي الكريم تظهر الرسالة لانك لم تحفظ السجل فكيف تضيف معلومات للسجل ......---------->>>>> اولا احفظ بالضغط على حفظ وتحديث ثم اضغط على المعرفون .....

ضع هذا في مربع النص الخاص بالمبلغ في التقرير ="#" & [Forms]![Form1]![المبلغ] & "#"

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

جرب هذا الكود لعله المطلوب اكتب في الخلايا e3,f3 الاسماء بعد كتابة التواريخ Sub bring_customers() Dim CustID As String: CustID = sheet2.[e3].Value Dim CustID1 As String: CustID1 = sheet2.[f3].Value Dim FromDt As Long: FromDt = sheet2.[d3].Value Dim ToDt As Long: ToDt = sheet2.[c3].Value Application.ScreenUpdating = False sheet2.[A5].CurrentRegion.Offset(1).Clear With sheet1.[A2].CurrentRegion .AutoFilter 3, CustID, xlOr, CustID1 .AutoFilter 2, ">=" & FromDt, xlAnd, "<=" & ToDt .Offset(1).EntireRow.Copy sheet2.Range("A" & Rows.Count).End(3)(2) .AutoFilter End With Application.ScreenUpdating = True End Sub Example.xlsm

السلام عليكم ورحمة الله وبركاته مبارك عليكم العشر المباركة سؤالي كيف يمكن اضافة كود أو عبارة في سطر معين من المديول بطريقة برمجية ....... في جزء الكود المرفق هو كود لاضافة كود اضافة قتح نموذج معين الى اكواد النموذج برمجيا .... اريد التعديل عليه ليصبح للمديول ... شاكرا لكم تعاونكم بارك الله فيكم AA.DoCmd.OpenForm "frmSn", acDesign Set MM = AA.Forms("frmSn").Module MM.InsertLines 17, " DoCmd.OpenForm " & Chr(34) & GG & Chr(34)

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

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

أشكرك أخي الكريم ....... جعلك الله مباركا في الدنيا والأخرة

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

السلام عليكم 🙂 رجاء مراجعة موضوع النسخة 2 من هنا : واجهة هذه النسخة: البرنامج يقوم بهذه الخطوات التي يوصي بها المحترفين (كما هو موضح في الصورة اعلاه) ، طريقة العمل: 1. اختار ملف اكسس ، 2. اذا الملف محمي بكلمة سر ، فيمكن كتابته في المربع المخصص ، حيث سيتم حفظه في ذاكرة الكمبيوتر ، والتي يجب عليك ان تدخلها يدويا للقيام بالخطوات 2 و 3 لمرة واحدة ، بينما البرنامج سيدخلها تلقائيا للخطوات التالية ، 3. يجب ان تمسك مفتاح الشفت ، ثم تضغط على زر Decompile ، ولا تترك الزر إلا لما ينتهي البرنامج من عمله ، عندما نرى الخطوات 8 و 9 🙂 هذه النسخة اسرع من النسخة السابقة ، وافضل 🙂 جعفر Decompile_3.zip

اخي الكريم اليس هذا ما طلبته انا لا اعمل على التخمين كان وجب عليك توضيح ذلك من البداية

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

الخبير الفاضل الفلاحجى شكرا على الاجابة التى افادتنى كثيرا

كل الشكر والتقدير والاحترام من القلب

وعليكم السلام ورحمة الله وبركاته يمكن تنفيذ الامر في حدث قبل التحديث Private Sub Form_BeforeUpdate(Cancel As Integer) ' ضع اوامر تنفيذ الاستعلامات هنا End Sub تحياتي

اعتقد هذا يفي بالغرض Sub Copy() Dim LastRow As Long LastRow = Sheets("Sheet1").Cells(Rows.Count, "b").End(xlUp).Row Sheets("Sheet1").Range("A" & LastRow - 9 & ":B" & LastRow).Copy Sheets("Sheet2").Range("h11") End Sub

جرب هذا الملف (معادلات مطاطة حتى 100 صف و يمكن الزيادة) مع حرية احتيار عدد الصفوف المطلوبة ( 10 أكثر اقل ) Ali_m.xlsx

كلمة مبدع قليلة في حقك

تفضل التعديل اخي الكريم ملاحظة قم بالغاء ارتباط النماذج لكي يعمل معك الكود تفضل الملف بعد التعديل f1.rar

حياك الله اخوي حسين 🙂 مثل ما يقول المثل: اليد الواحدة ما تصفق ، وهذا المنتدى ينمو ويرتقي بأيدينا جميعا ، ولولا موضوعك ، لما صار له تنسيق 🙂 (ملاحظة للجميع ، انا اخذت اذن من الاستاذ حسين علشان اعمل تغيير في موضوعه 🙂 ) جعفر

لو فرضنا ان هذه العلامة موجودة في العامود الأول A هذا الماكرو يقوم بما تريد Option Explicit Sub Test() Dim Ro#, i# Ro = Cells(Rows.Count, 1).End(3).Row For i = 1 To Ro If Range("A" & i) <> vbNullString Then Range("A" & i) = _ Replace(Range("A" & i), Chr(39), """") End If Next End Sub

وعليكم السلام مشاركه مع اخوانى نفس الحل المقدم من اخى واستاذى @kanory جزاه الله خيرا 💐 بالتوفيق m1.accdb

اذا كان بإمكانك ان تستعمل نموذج فيه مجموعة صفحات/السنة ، وفي صفحة تضع نموذج فرعي ، سيكون اسهل لك في التعامل معاه في الكود : . 🙂 جعفر

وهذه طريقة أخرى مشاركة مع العمدة @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

حياك اخي ابا بسملة .... تنورنا

ربما هذا المطلوب .... 233.rar

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

هنا موضوع يتحدث عن مطلوبك

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

اخي الكريم جرب على القاعدة المرسلة لك ..... وأعلمني بالنتيجة kanory.rar

لم يعمل معي بعد محاولات عدة ....... ولا أعلم السبب

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

وعليكم السلام احمد عدلت على الملف المرفق..جرب و خبرنا اسم المستخدم user1 و كلمة المرور 111 تحياتي Login Form.zip

السلام عليكم Dim LastRow As Long Dim rngCriteria As Range, rngValue As Range التعريف عن متغيرات =============== LastRow = Cells(Rows.Count, "D").End(xlUp).Row لاستخراج رقم أخر صف به بيانات (في مثالك 13) ======= Set rngCriteria = Range("D2:D" & VBA.CStr(LastRow)) تعريف المدى من D2 الى D و أخر صف به بيانات ===== Set rngValue = Range("F2:I" & VBA.CStr(LastRow)) تعريف المدى من F2 الى I و أخر صف به بيانات ======================= Application.ScreenUpdating = False إيقاف اهتزاز الشاشة === With rngCriteria .Offset(0, 2).FormulaR1C1 = "=SUMIF(Kind,RC[-2],Sales)" .Offset(0, 3).FormulaR1C1 = "=SUMIF(Kind,RC[-3],Purchases)" .Offset(0, 4).FormulaR1C1 = "=SUMIF(Kind,RC[-4],SalesRefunds)" .Offset(0, 5).FormulaR1C1 = "=SUMIF(Kind,RC[-5],PurchasesRefunds)" End With هذه الجزئية ساتناول السطر .Offset(0, 2).FormulaR1C1 = "=SUMIF(Kind,RC[-2],Sales)" والباقي بنفس الفكرة في المدى D2:D واخر صف فاضي والذي تم تعريفه بهذا الاسم (rngCriteria) الخلايا المزاحة بمقدار عمودين يتم وضع هذه الصيغة (دالة ) فيها "=SUMIF(Kind,RC[-2],Sales)" وكما هو معروف بالنسبة لدالة SUMIF وطريقة عملها مع العلم ان المدى Kind والمدى Sales تم تعريفهما مسبقاً =========================== rngValue.Value = rngValue.Value هذا السطر يعني ان قيمة المدى من F2:I واخر خليه بها بيانات التي تم جلبها بالدالة يتم استبدال الدالة بالقيمه الناتجة عنها جرب مسحه وسترى ان الخلايا تحوي معادلات ================ ان شاء الله ان اكون وفقت في الشرح

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

أخي الكريم صفوت ماتزعلش مني إنت سؤالك مش محدد من البداية ياريت يكون طلبك بعد كدا أوضح شوية لا تزعل لإنه العتاب بيكون بين الأحباب طلبك الأخير كما فهمت أنك تريد تنفيذ الماكرو بطريق آخر غير طريق الزر : ضع الكود التالي في الحدث Worksheet_Change Private Sub Worksheet_Change(ByVal Target As Range) hide_all End Sub أخوك أبو البراء

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