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

جرب هذا الماكرو ( لا صفوف فارغة في الجداول لان الماكرو يتوقف عند أول حلية فارغة) Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr i = 3 Do Until Sheets(Sh).Range("B" & i) = vbNullString dic(Sheets(Sh).Range("B" & i).Value) = vbNullString i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub الملف مرفق Muneef.xlsm

تفضل ..... تحويل.accdb

هل هاد طلبك قاعدة البيانات الشهادات المدرسية 02.accdb

أكثر اختصاراً Sub test() Dim a As Variant Dim i As Long Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim sh3 As Worksheet Set sh1 = Sheets("sheet1"): Set sh2 = Sheets("sheet2"): Set sh3 = Sheets("sheet3") a = Split(Join(Application.Transpose(sh2.Range("b3:b" & sh2.Cells(Rows.Count, 2).End(xlUp).Row)), "#") _ & "#" & Join(Application.Transpose(sh3.Range("b3:b" & sh3.Cells(Rows.Count, 2).End(xlUp).Row)), "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If a(i) <> "" Then If Not .exists(a(i)) Then .Add a(i), .Count + 1 End If End If Next sh1.Range(sh1.Range("a3"), sh1.Range("a3").End(xlDown)).Resize(, 2).ClearContents sh1.Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub جلب الاسماء من عدة شيتات مع عدم التكرار.xlsm

بعد اذنك استاذ خيار آخر حتى بوجود فراغات Sub test() Dim a, b As Variant, i a = Application.Transpose(Sheets("sheet2").Range("b3:b" & Sheets("sheet2").Cells(Rows.Count, 2).End(xlUp).Row)) b = Application.Transpose(Sheets("sheet3").Range("b3:b" & Sheets("sheet3").Cells(Rows.Count, 2).End(xlUp).Row)) a = Split(Join(a, "#") & "#" & Join(b, "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If a(i) <> "" Then If Not .exists(a(i)) Then .Add a(i), .Count + 1 End If End If Next Sheets("sheet1").Range(Sheets("sheet1").Range("a3"), Sheets("sheet1").Range("a3").End(xlDown)).Resize(, 2).ClearContents Sheets("sheet1").Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub

بعد اذن الأستاذ حسين ولإثراء الموضوع يمكنك هذا بهذه المعادلة =IFERROR(IF(B2="عام",VLOOKUP($E2&"/"&$D2,الحالة!$N$2:$Q$80,2,0),VLOOKUP($E2&"/"&$D2,الحالة!$H$2:$K$80,2,0)),"") المنتوج+المحور+الاستحقاق1.xlsx

ربما هذا طلبك حسب فهمي لموضوعك .... Database1 (7).rar

عمل زر تنبيه اقتراب موعد معين في TextBox مع التنسيق الشرطى الكود كود الفرق =TODAY()-D2 كود التنبية =IF(K2<=0;"خطأ بالتاريخ";IF(K2<=10;"باقى ايام";"مستمر معنا")) يمكن عمل ليست بناء على الموجود بالفورم

طباعة شيت وطباعة فورم وتسجيل تاريخ اليوم الاكواد طباعة شيت Private Sub CommandButton8_Click() Application.Dialogs(xlDialogPrinterSetup).Show ThisWorkbook.Sheets("magdi").PrintOut copies:=1 End Sub طباعة فورم Private Sub CommandButton9_Click() Frame3.Visible = False Frame5.Visible = False Frame6.Visible = False Frame23.Visible = False Me.PrintForm Frame3.Visible = True Frame5.Visible = True Frame6.Visible = True Frame23.Visible = True End Sub تاريخ اليوم Private Sub TextBox6_Enter() TextBox6.Value = Date TextBox6 = Format(TextBox6, "dd/mm/yyyy") End Sub

اذا كان هناك فراغات يمكن ان نتجاوزها بهذا الكود و لا لزوم لما لا يلزم من وضع 2 Arrays واحد لكل شيت Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i%, x% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr x = Sheets(Sh).Cells(Rows.Count, 2).End(3).Row i = 2 Do Until i > x If Sheets(Sh).Range("B" & i) <> "" Then dic(Sheets(Sh).Range("B" & i).Value) = vbNullString End If i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub

وعليكم السلام يمكنك ذلك من خلال التنسيقات الشرطية بهذه المعادلة =and($C2<=TODAY()-3,$c2<>"") متابعة1.xlsx

السلام عليكم 🙂 المرفق يحتوي على النسختين mdb و accdb ، ويعمل على النواتين 32بت و 64 بت 🙂 النسخة السابقة: عندما يعطي برنامج الاكسس اخطاء - النسخة رقم 3 - قسم الأكسيس Access - أوفيسنا (officena.net) بعض الاوقات عند تشغيل برنامج اكسس ، نجد انه يغلق بدون سبب ، بمثل هذه الرسالة: . او يُظهر اخطاء ، مثل هذه الرسائل وغيرها : . . . هذا معناه ان برنامجك يحتاج تنظيف من الاخطاء التي فيه ، او يحتاج الى استعادة حيويته مرة اخرى ، بالتنظيف والصيانة 🙂 وعادة نقوم بهذا العمل على برنامج الواجهات FE ، ولكن برنامج الجداول BE يستفيد منه كذلك. نافذة البرنامج : . 1. نختار الملف ، سواء mdb او accdb ، اما ملفات mde و accde ، فلن تستفيد من Decompile/Compile ، ولكنها ستستفيد من الضغط والاصلاح ، وعمل نسخ اضافية ، 2. اذا البرنامج فيه كلمة سر (ليس كلمة سر المستخدمين ، ولا كلمة سر الكود VBE) ، فيمكنك كتابة كلمة السر هنا ، وسيقوم البرنامج بحفظه/نسخه في ذاكرة الكمبيوتر ، وتستطيع استعمال الالصاق Ctl+v عندما يسألك البرنامج ، كما يقوم البرنامج بإستخدامه في فتح برنامجك لمراجعة الاخطاء. اذن هناك خطوة يمكن للبرنامج ان يستخدم كلمة السر مباشرة ، وهناك خطوة يجب عليك ادخال كلمة السر عن طريق اللصق Ctl+v ، تم إضافة ميزة عمل النسخ الاحتياطية لبرنامجك ، بحيث تحفظ نسخة من برنامجك بعد التنظيف ، في المجلد الذي تختاره ، ويكون الحفظ المسلسل هكذا : . يعني بدل ان تحفظ نسخة من برنامجك بطرقك الخاصة ، تستطيع وبعد تعديل برنامجك ، ان تتأكد انه خالي من الشوائب ، ويعمل نسخه منه تلقائيا 🙂 وهناك عدة طرق لإختيار مجلد الحفظ: 3. حفظ الملف في نفس مجلد البرنامج ، 4. اختار المجلد ، وبعد اختياره ، تستطيع ان تنقر على الزر 9 ليقوم البرنامج بحفظ هذا المجلد/المسار في البرنامج للمرات القادمة ، 5. اول مسار تريد حفظه هو: استعمل الخطوة 4 في فتح المجلد الرئيسي لحفظ النسخ الاحتياطية (واذا ما كان عندك ، فقم بعمله من الآن) ، ثم احفظ المجلد/المسار بالزر 9. وبعدها ، البرنامج تلقائيا يختار هذا المجلد (اذا قمت بحفظه بواسطة الزر 9) كلما فتحت البرنامج ، اي انه اول سجل في الجدول ، 6. عن طريق الخطوة 4 ، تستطيع حفظ اي عدد من المجلدات ، ولاحقا تستطيع ان تختار هذا المجلد لحفظ النسخة الاحتياطية فيه ، 7. عدم عمل نسخ احتياطية ، للأسف الشديد 😞 8. عند اختيار اي من الاختيارات اعلاه ، سيضع البرنامج مسار مجلد النسخ الاحتياطية هنا ، 11. الآن نطلب من البرنامج ان يقوم بعمله ، بالخطوات التالية : أ. يحفظ نسخة من البرنامج وقبل مساسه (حتى اذا لا قدر الله وحصلت مشكلة في العمل ، يمكنك الرجوع لهذه النسخة) ، ويقوم البرنامج بعمل النسخة في مجلد برنامجك ، بإضافة bak_ في نهاية اسم الملف ، كما في الصورة ، واذا احتجت لإستعمال الملف لاحقا ، فقط قم بحذف bak_ وسيعمل البرنامج : ب. ضغط واصلاح : لما تحذف سجلات من برنامجك ، فإن البرنامج يعطي اشارة الى الجدول بإخفائه ، ولا يقوم بحذفه إلا بعد الضغط والاصلاح ، عند عمل فهرسة لحقول في الجدول ، فإن البرنامج يحتاج الى ضغط واصلاح حتى يقوم بترتيب اعدادات الفهرسة ، عند العمل على البرنامج لفترة طويلة بإضافات وتعديل وحذف ، فالبرنامج يحتاج الى ضغط واصلاح لإعادة ترتيب الفهرسة لسرعة عمل البرنامج ، قد يتم خطأ في تسجيل سجل ، ربما بسبب انطفاء الكهرباء ، او اغلاق الكمبيوتر وبدون اغلاق البرنامج ، وهذا السجل يجعل الجدول لا يعمل بطريقة صحيحة ، والضغط والاصلاح يحل هذه الاشكالية ، البرنامج عبارة عن ملف في الكمبيوتر ، ولما تعمل البرنامج ، فإن الكمبيوتر يحفظ البرنامج على المكان الفارغ من القرص الصلب ، ولما تضيف سجلات جديدة ويكبر حجم البرنامج ، فقد يحفظ الكمبيوتر الجزء الجديد في مكان آخر على القرص الصلب ، مكان غير ملاصق للجزء الاصل (وهذه طريقة حفظ الكمبيوتر للملفات) ، وبهذه الطريقة يصبح الملف موجدا على اجزاء مختلفة من القرص الصلب ، مما يجعل البرنامج ابطأ ، ولما تعمل ضغط واصلاح ، فإن الاكسس يقوم بحساب المساحة المطلوبة للبرنامج ، ثم يقوم بعمل برنامج جديد في مكان جديد على القرص الصلب ، وينسخ البرنامج اليه ، مما يجعل البرنامج اسرع ، بالاضافة الى امور اخرى لا يتم حلها إلا بالضغط والاصلاح ، الضغط والاصلاح لا علاقة له بالكود ، ولا يقوم بفحصه. ج. Decompile : لما نكتب الكود ، الاكسس يحتفظ بكل سطر بلغة P-Code الخاصة بمايكروسوفت (والتي تُستخدم لبعض البرامج الاخرى كذلك) ، وعند تنفيذ الكود ، فالاكسس ينفذ كود لغة P-Code ، وفي بعض الاحيان من كثرة التعديلات على الكود ، فإنه لا يتم تحديث P-Code بطريقة صحيحة ، فينتج عنه رسائل اخطاء اكسس ولا يعمل البرنامج بطريقة صحيحة ، وعند عمل Decompile ، فالاكسس يحذف كود P-Code القديم ، ويسجل فيه كود جديد من VBA ، مما يجعل البرنامج اصغر في الحجم زيادة في الكفائة. د. Compile : بهذه الطريقة ، نتأكد من عدم وجود اخطاء في الكود ، وبقايا ومخلفات ، مثل: لما نحذف كائنات في النموذج/التقرير ، ولا نحذف الحدث الخاص بها ، فالكود يجب حذفة ، لعدم وجود الحدث الي يستعمله ، لما نحذف كائن في النموذج/التقرير ، وفي الكود نكون قد اعطيناه قيمة ، فيجب حذف المسمى من الكود ، عند كتابة كود بطريقة غير صحيحة وغير مكتملة ، فيجب تصحيحها ، وهذه الخطوه مهم لتحويل البرنامج الى mde او accde . يحاول البرنامج القيام بهذا العمل لبرنامجك ، ولكنه اذا لم يستطيع ويحصل على اخطاء ، فإنه يخبرك بهذا ، ويخبرك مكان الخطأ في الكود ، سواء وحدة نمطية او نموذج او تقرير ، ويعطيك مثل الرسالة التالية ، والتي اذا اخترت نعم ، فيوقف البرنامج ، . ويأخذك لبرنامجك الى نافذة الكود VBE ، ثم يجب عليك ان تعمل التالي يدويا: . وتُصلح الاخطاء التي في برنامجك ، الى ان لا يعطي برنامجك اخطاء اخرى ، وبعدها تستطيع ان ترجع الى البرنامج ليقوم جميع الخطوات مرة اخرى. هـ. اذا اشتغلت خطوات البرنامج وبدون اخطاء ، فهنا يقوم البرنامج بعمل نسخة احتياطية من برنامجك ، وبالتسلسل الصحيح ، وفي المجلد الذي اخترته. 12. البرنامج يخبرك عن الخطوات التي تمت 🙂 جعفر Decompile_4.accdb..zip Decompile_4.mdb..zip Decompile_4.2.accdb.zip

ماكرو بحث واستبدال اسم أو رقم بفورم الاكسل وبعددة طرق الفيديو الصور

ممكن مثالك مصغر عشان نعرف تفاصيل اكثر ونطبق

إحترامتي لك أخي

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

وعليكم السلام ورحمة الله وبركاته هناك عدة طرق منها 3 موضحة بالجدول المرفق وطريقتك الموجودة =DATEDIF(F2,G2,"MD") احذف m من MD بهذا الشكل =DATEDIF(F2,G2,"D") 0الفرق بين تاريخ.xlsx

السلام عليكم ورحمة الله وبركاته =IF(N6<=G6, I6, IF(N6<=G7, I7,IF(N6<=G8, I8, IF(N6<=G9, I9,IF(N6<=G10, I10, IF(N6<=G11, I11,IF(N6<=G12, I12, IF(N6<=G13, I13,IF(N6<=G14, I14, IF(N6<=G15, I15,IF(N6<=G16, I16, IF(N6<=G17, I17,IF(N6<=G18, I18, IF(N6<=G19, I19,I20)))))))))))))) الدالة الشرطية.xlsx

ملفك سليم مفتوح بدون كلمة مرور ولا حاجة اظن المشكلة في جهازك المشكلة.xlsm

قاعدة البيانات الشهادات المدرسية 02.zip

ان شاء الله جزاك الله خيرا و حفظك و رعاك و جعلها في ميزان حسناتك ابعد عنك كل مكروه قل أمين

الكود كما يجب ان يكون (ثم ان اليوزر عريض بشكل لا تستطيع ان تراه بأكمله على الــ Vb Editor) التقليل من عرضه و عرض الليست بوكس (مع اني لا أحب اليوزر ولا أطيق النعامل معه) Private Sub CommandButton1() Dim i As Long, s As Long, LF% Dim Rg As Range Dim Source As Worksheet Dim Rg_to_find As Range Dim Mot For Each ctl In Me.Controls If TypeName(ctl) = "OptionButton" Then If ctl.Value = True Then Mot = ctl.Name Exit For End If End If Next ctl Set Source = Sheets("القيود اليوميه 0") LF = Source.Cells(Rows.Count, "F").End(3).Row If LF < 9 Then Exit Sub Select Case True Case Mot = "kod": Set Rg_to_find = Source.Range("C8:C" & LF) Case Mot = "mosm": Set Rg_to_find = Source.Range("D8:D" & LF) Case Mot = "Clirnt": Set Rg_to_find = Source.Range("F8:F" & LF) Case Mot = "pyan": Set Rg_to_find = Source.Range("H8:H" & LF) Case Mot = "Hot": Set Rg_to_find = Source.Range("G8:G" & LF) Case Mot = "madin": Set Rg_to_find = Source.Range("I8:I" & LF) Case Mot = "daen": Set Rg_to_find = Source.Range("J8:J" & LF) Case Mot = "snd": Set Rg_to_find = Source.Range("b8:b" & LF) Case Mot = "ced": Set Rg_to_find = Source.Range("A8:A" & LF) Case Else: Exit Sub End Select With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(7, s + 1) Next End With For i = 8 To LF If UCase(Rg_to_find.Cells(i - 7)) Like ("*" & UCase(Mot) & "*") Then With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(i, s + 1) Next End With End If Next End Sub

اضغط القاعدة قبل رفعها باى برنامج ضغط ملفات او ارفع القاعدة على موقع لرفع الملفات وهات الرابط

كلمات تتحرك داخل الفورم باستخدام WebBrowser الاكواد الاداة WebBrowser1 ------ Option Explicit Public LeTexte As String Public LaCouleur As String --- Private Sub UserForm_Initialize() LeTexte = Sheets("magdi").Range("a1").Text LaCouleur = "#990000" ParametresHtml End Sub Sub ParametresHtml() UserForm3.WebBrowser1.Navigate _ "about:<html><body scroll='no'><font color= " & LaCouleur & " size='8' face='NEW'>" & _ "<marquee>" & LeTexte & "</marquee></font></body></html>" End Sub

وعليكم السلام ارفق مثال ليتم مساعدتك اخي الكريم

شاكر ومقدر جهودك

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

وعليكم السلام -كان عليك استخدام خاصية البحث بالمنتدى فطلبك تكرر كثيراً تنسيق التاريخ في عمود ليست بوكس وهذا أخر كود تنسيق الارقام والتاريخ في الليست بوكس

ماشاء الله الله يجزيكم الخير ويبارك فيكم ماشاء الله طريقتين رائعات ويقدرنا واياكم على فعل الخير

وعليكم السلام نعم انا مع اخي احمد في ضرورة رفع مرفق يعرض المشكلة توفيرا للجهد والوقت وبما ان الفكرة جديدة علي اليك طريقة لتأسيس بنائها 1- الجدول الرئيس لتسجيل بيانات الدراجات 2- الجدول الفرعي لتسجيل بيانات المالكين يتم اظهار الدراجة ومالكها الحالي في التقرير بناء على معلومتين الأولى : كون المالك الحالي آخر المسجلين الثانية : كون المالك لم يسجل له تاريخ نهاية التملك وفي المرفق ادناه تم اعتماد المعلومة الثانية dbmotors.mdb

وعليكم السلام سواء فى الماكرو او محرر الاكواد استعمل التالى لايقاف الرسائل التحذيريه DoCmd.SetWarnings False ' ضع هنا استعلام الالحاق DoCmd.SetWarnings True بالتوفيق

السلام عليكم ورحمة الله اكتب هذه المعادلة هى اول خلية مقابلة للرقم المطلوب ثم اضغط Ctrl + Shift + Enter ثم اسحب نزولا لاخر خلية تريدها =IFERROR(IF(SMALL(IF($B$5:$G$5=$C12;COLUMN($B$5:$G$5));1)>0;"a";"");"x")

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

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

السلام عليكم تفضل اخي الكريم Private Sub Form_BeforeUpdate(Cancel As Integer) DoCmd.SetWarnings False If id1 = 1 Then If MsgBox(" هل تريد حفظ التغييرات؟ ", vbYesNo, " تأكيد الحفظ") = vbNo Then Me.Undo Exit Sub DoCmd.Close acForm, "form1" End If End If DoCmd.SetWarnings True End Sub ولكن الرسالة الآن لن تظهر لن الحقل Id1 غير منضم اربط النموذج والحقل بجدول وسترى النتيجة ان شاء الله مثال اوفيسنا كود عند اغلاق النموذج.rar تحياتي

فورم دخول ب 2 سرى مع تحريك ليبل فى الفورم يخفى السرى الاكواد اسفل الفيديو

جرب هذا الكود Option Explicit Sub colorize() Dim lr%, i% Const n = 35 Const Mot = "Saturday" With Sheets("My_sheet") lr = .Cells(Rows.Count, 1).End(3).Row .Range("A1:A" & lr).Interior.ColorIndex = xlNone For i = 1 To lr If .Cells(i, 1) = Mot Then .Cells(i, 1).Interior.ColorIndex = n End If Next End With End Sub الملف مرفق Sayaed.xlsm

اليك المرفق قم بفك الضط وضع الفولدر REVI في :c الفولدر REVI تجد فيه الملف الرئيسي "تقويم" وفلدر "vi" لتخزين استمارات قم بتجربة بعد اضافة عميل او ثلاثة وابدي رأيك اتمنى ان تجد فيه غايتك REVI.rar