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

Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub --------------------- Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub ماكرو عادي يتم تنفيذه من قبلك

ولا اجمل يا شايبنا

ممكن وبعيد عن التعقيدات ممكن نستدعي البيانات باستخدام دالة Dlookup على شكل مصفوفة في حدق عند النقر على الاسم في النموذج الفرعي نضع الامر Dim a, x As Variant a = DLookup("[id]&'|'&[ptitle]&'|'&[pname]&'|'&[code]", "reservation_tbl", "[pname]='" & [pname] & "'") x = Split(a, "|") Me.Parent!ID = x(0) Me.Parent!ptitle = x(1) Me.Parent!pname = x(2) Me.Parent!code = x(3) استدعينا قيمة اربع حقول بمعيار الاسم وممكن اضافة اي عدد من الحقول ولكن لابد من الفصل بينهم باستخدام &'|'& لنتمكن بعد ذلك من تقسيم المصفوفة الملف مرفق اخونا الشايب lab.accdb

تفضل أخي الكريم Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), a(i, 10) & " NO - " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 14).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub

هنيئا لكما @Foksh و @عمر ضاحى هذه الثقة التي انتم تستحقونها .. اسأل الله لكما التوفيق والسداد ...

اخي الكريم استخدم هذه الدالة لعدد الأيام بين تاريخين DateDiff("d", [تاريخ البداية], [تاريخ النهاية])

شكرا لك اخي مرادي على مساعدتك ومساهمتك ,,, مقدرا لك جهدك المبذول ,,, وكانت هذه نقطه رقم (1) من النقاط التي شاركتها للمساعده اتمنى من الجميع ان يتم مساعدتي في بقية النقاط ... شكرا مرة اخرى

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

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

تفضل أخي محاولتي . طباعة السجل مرةً واحده.accdb

جرب هذه الفكرة ، واستغلها حسب حاجتك Try Print.accdb

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

السلام عليكم اخى الفاضل Mohamed Abo Elala ان كانت قاعدة المعلومات مقسمة ارجو ان تراعى عملية الربط بينها وبين الجداول سواءا كانت على نفس الجهاز او اى جهاز اخر على الشبكة اتمنى لك التوفيق

السلام عليكم اخى الفاضل @murady نعم هذا ما اريد شاكر سعه صدركم لاحتوائنا وجزاكم الله خير

السلام عليكم اخى الفاضل محمد سعيد رشاد عندما لا تجد الاسم فى الفورم يتم إضافته يدويا واضغط enter سوف يضاف الى الجدول المراد ارجو انى فهمت قصدك لعل هذا ما تريد بالتوفيق والسداد murad1.rar

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

مبارك للسادة الأساتذة الأفاضل دائما فى ازدهار وتقدم تمنياتى لكم بالتوفيق وتمام السداد

اذا اردنا بقاء نموذج visit_frm غير منضم وبدون اجراء تغيير على النماذج والحقول فمن اسهل الطرق تحميل قيمة الحقول ضمن امر فتح النموذج في مثال الاخت في زر الامر النتائج نضع الامر التالي DoCmd.OpenForm "visit_frm", , , , , , ID & "|" & ptitle & "|" & pname & "|" & code وكما تشاهد حملنا قيمة اربع حقول ويمكن زيادة عدد اكبر من ذلك وفصلنا بين كل حقل والاخر بـ &"|"& والغرض استخدامها كفاصل بين قيمة كل حقل والاخر ثم في نموذج visit_frm في حدث عند الفتح نضع الامر If Not IsNull(Me.OpenArgs) Then Dim k As Variant k = Split(Me.OpenArgs, "|") ID = k(0) ptitle = k(1) pname = k(2) code = k(3) End If اخونا الشايب

أهلا @Foksh في ظني أن هذا ملف وورد غُيرتْ لاحقة الملف إلى accdb! هذا كل ما في الأمر! جميع تطبيقات أوفس التي تعتمد على ملفات XML في بنائها هي من هذا القبيل! ميزة 7z أن كل ملف يمكن إجراء فك الضغط عليه! جرب إنشاء ملف (وورد، أكسل، بوربوينت،..) وقم بفك الضغط عنه باستخدام 7z سوف تجد نفس النتيجة!! الهنود، يستخدمون هذا الاسلوب لكسر كلمة المرور لهذه الملفات!! جرب مع أكسل! هذا لا ينطبق على أكسس لأنه لا يعتمد على XML في بنائه!!

لم أترك الموضوع وفعلاً توجهت لفكرة تعديل ملف من اصدار أقل لإصدار أعلى ولكن لم يستطع نفس البرنامج تحليل وفتح الملف بصيغة Accdb ، وليس من طبعي أن يستعصي موضوع مثل هذا دون البحث عنه ومعرفة آلية إنشاء كهذا الملف والذي صار أشبه بملف مضغوط على هيئة ملف آكسيس 🤔

منكم نتعلم استاذي الكبير ،، 😊

^_^ سبقتني لكن احب ان اضيف مشاركه مع اخي @Foksh تفضل هل هذا ما تريد 1234.rar ولتعم الفائدة وتضويح ما تم تم استخدام هذا الكود Sub GetInfo1() Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = db.OpenRecordset("Sale_Reg", dbOpenDynaset) With rst .AddNew ![Sale_code] = DLookup("code", "main_itemn", "code=" & "Sale_code") ![Sale_Number] = 1 ![Sale_invoice] = Forms![Sale]![Invoice_Number] ![SSale_Price] = DLookup("Slae_price", "main_itemn", "code=" & "Sale_code") ![Sale_Date] = DLookup("Reg_Date", "main_itemn", "code=" & "Sale_code") ![Sale_Item_Name] = DLookup("item", "main_itemn", "code=" & "Sale_code") ![frosh_date] = Date ![scompany_name] = DLookup("company_name", "qry1", "code=" & "Sale_code") .Update .Close End With Set rst = Nothing db.Close Set db = Nothing End Sub مع ان هناك حلول اخري لكن وجدت الاسهل والاسرع للحلول دون تغير (او فرض راي) على المبرمج

هل هذا طلبك ؟؟ 1234.accdb لا تنسى ، اذا انتهت المشكلة ولله الحمد ، فقط اختر الإجابة كأفضل إجابة

Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Cells(Rows.Count, 5).End(xlUp).Row lr = lr + 1 ws.Cells(lr, 5) = Me.TextBox1.Value ws.Cells(lr, 6) = Me.TextBox2.Value ws.Cells(lr, 7) = Me.TextBox3.Value ws.Cells(lr, 8) = Me.TextBox4.Value ws.Cells(lr, 9) = Me.TextBox5.Value ws.Cells(lr, 10) = Me.TextBox6.Value ws.Cells(lr, 11) = Me.TextBox7.Value ws.Cells(lr, 12) = Me.TextBox8.Value ws.Cells(lr, 13) = Me.TextBox9.Value ws.Cells(lr, 14) = Me.TextBox10.Value ws.Cells(lr, 15) = Me.TextBox11.Value ws.Cells(lr, 16) = Me.TextBox12.Value ws.Cells(lr, 17) = Me.TextBox13.Value For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub او Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Range("E" & Rows.Count).End(xlUp).Row With ws .Cells(lr + 1, "E").Value = Me.TextBox1.Value .Cells(lr + 1, "F").Value = Me.TextBox2.Value .Cells(lr + 1, "G").Value = Me.TextBox3.Value .Cells(lr + 1, "H").Value = Me.TextBox4.Value .Cells(lr + 1, "I").Value = Me.TextBox5.Value .Cells(lr + 1, "J").Value = Me.TextBox6.Value .Cells(lr + 1, "K").Value = Me.TextBox7.Value .Cells(lr + 1, "L").Value = Me.TextBox8.Value .Cells(lr + 1, "M").Value = Me.TextBox9.Value .Cells(lr + 1, "N").Value = Me.TextBox10.Value .Cells(lr + 1, "O").Value = Me.TextBox11.Value .Cells(lr + 1, "P").Value = Me.TextBox12.Value .Cells(lr + 1, "Q").Value = Me.TextBox13.Value End With For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub

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

أخي الكريم @2saad يبدو أن حضرتك لم تنتبه لتعديل مشاركتي بوضع كلمة val قبل قيمة مربع النص لتحويلها إلى رقم بالتوفيق

وعليكم السلام ربما Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed End If Next End With End Sub أو Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow End If Next End With End Sub مع المحافظة على لون الخلية عند تغيير القيمة

Private Sub Worksheet_Change(ByVal Target As Range) Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:I" & [I65000].End(xlUp).Row + 10) Set rng1 = CreateObject("Scripting.Dictionary") Set rng2 = CreateObject("Scripting.Dictionary") If Target.Column <> 6 And Target.Column <> 9 Then Exit Sub For Each J In a rng1(J.Value) = J.Value Next J For Each J In b rng2(J.Value) = J.Value If Not rng1.exists(J.Value) And rng2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If rng1.exists(J.Value) Or rng2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub test.xlsb

تفضل أخي . DD403-1.accdb

ترليون مبروك تستاهلوا كل خير نفعنا الله بعلمكم

اولا بحب اشكرك شكرا جزيلا على هذه الشهادة العظيمه استاذي @ابوخليل فلست ارى نفسي انى اقتربت من هذا المستوي ولسه قدامي الطريق طوييييييييل حتى اصل لمثل هذه الشهادة وهنا احب ان اقدم شكري وتقدير لاساتذتى الكرام @jjafferr و @ابوخليل و @ابو جودي @Eng.Qassim @Moosak الكثير هنا كلهم اساتتى واتعلمت منهم الكثير سائل المولى ان يبارك لنا فى اعمارهم وان يحفظهم من كل شر وان يبارك لهم فى جميع امورهم واهلهم اجمعين فلكم جزيل الشكر جميع على ما قدمتوه لنا فى هذا الصرح العظيم ❤️

بعد اذن الاخ علي _retardالحضور والانصراف.xlsx

وعليكم السلام الحضور والانصراف.xlsx

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة طلب برنامج صادر ووارد تم ارفاق ملف الموضوع من الفاضل _ أ / شوقي ربيع شرح البرنامج اختر كما هو في الجهة اليمنة للصورة الفرع الذي ستعمل عليه صادر او وارد للاستعلام اختر استعلام ثم من القائمة الاولى اختر طريقة البحث ستجد في القائمة 6 انواع للبحث الرقم - التاريخ - الجهة (المرسلة اة المرسل اليها) - تاريخ الكتاب - رقم الكتاب الامر نفسه لصادر او الوارد بعدها ستضهر جميع النتائج في القائمة المنسدلة الثانية ابحث فيها عن الذي تبحث عنه بعد اختياره ستضهر النتيجة المتعلقة به في الجدول كما هو مبين في الصورة اذا اردت التعديل على البيانات التي ضهرت قم بتعديل ماشئة من البينات ماعدا الرقم (المسلسل) ثم اضغط زر(اضغط لاتمام التعديل) ملاحضة لم ادرج خاصة لتعديل الصورة لادخال بينات جديدة اختر ترحيل ثم املئ البينات الازمة في الجدول المقابل ثم اضغط على زر (اضغط لاتمام الترحيل) ستضهر لك نافذة الماسح الضوئي ان كان متصل اضغط زر موافق لأخذ صورة من الماسح الضوئي سيتم حفض الصورة في المجلد المدرج مع المرفق وفي الصفحة الصادر او الوارد مع باقي البينات التي رحلت للطباعة اعتقد ان الامرواضح ملاحضة هامة ضع ملف الاكسل والملف المدرج معه المسمى Image في نفس الملف او القرص اي لاتضع الملف في جهة وملف الاكسل في جهة اخرى لكي يشتغل البرنامج بشكل سليم وايضا لا تقم بتغيير اسم الملف او الملفات التي بداخله او اسماء الصور التي ستحفض فيه بانسبة للاعضاء وللافادة ستجدون في الملف الكود الذي يقوم باخذ صورة من الماسح الضوئي مع حفظ الصورة في ملف خارجي وايضا في ملف الاكسل نفسه ارجو ان يكون فيه الفائدة لجميع الاعضاء كما التمس العذر من الاستاد القدير عبد الله باقشير لاني استعملة اكواده(دالة وضع صورة في شكل تلقائي و التقاط صورة لتحديد خلايا او صورة) وقمة باتعديل عليها و لا تنسونا من صالح الدعاء برنامج صادر و وارد_سركى.rar

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة شرح كود يعمل بطريقة دالة VLOOKUP داخل يوزرفورم تم ارفاق كود الحل من الفاضل _ أ /رجب جاويش _ احمد فضيله و لا تنسونا من صالح الدعاء تحياتى userform2 (CALL CENTER)_RAGAB.rar FADILA (2).rar FADILA 2013.rar