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

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

جرب الكتابة داخل المربع الأول وانظر النتيجة .... ايقاف علامة جدولة.accdb

الاخ smfsho2009 شاهد المرفق Test_1.xls

كل عام وجميع الاخوة بالمنتدى بالف خير من الجميل ان نبدأ العام بتهنئة بكود اكسس تحياتي للجميع test.rar

مشاركة مع أخي خالد ..... barna.accdb

تفضل ....... Data.rar

جرب هذا الماكرو Option Explicit Sub ABSCENT() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 2) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "Q") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Tarhil_3iyab.xlsm

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

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

اهلا بك بالمنتدى عليك فقط بالضغط على أيقونة إظهار الفورم أنا أعمل على اكسيل 2010 ولكن عليك بعمل ما تريد من زر او ايقونة وعليك بربطها بهذا الكود وذلك من خلال فتح مديول جديد ولصق هذا الكود به Sub Show() Application.Visible = False UserForm1.Show End Sub 1رصد.xlsm

وعليكم السلام-تفضل 1111.xlsx

جربي المرفق Test1.accdb DoCmd.SetWarnings False If [خيار12] = True Then DoCmd.RunSQL "UPDATE table1 SET table1.yesno = yes " Me.Requery Else DoCmd.RunSQL "UPDATE table1 SET table1.yesno = no " Me.Requery End If DoCmd.SetWarnings True

انتظرت ردك اخي الكريم فان كنت تقصد تحديد الاسم الاول في القائمة عن الضغط على الزر فاليك الامر التالي Me.txtliste3.Selected(0) = True تحياتي

اتفضل شوف المثال التالى ان شاء الله يفيدك وجزاه الله خيرا استاذ محمد ندا كان فى مثال تانى عندى لام عهود بس مش لاقيه حاليا هدور عليه تانى تقبل تحياتى بالتوفيق _ترقيم غير تلقائى بنطاقات متعددة بنفس الجدول خمس شركات فى جدول واحدNumering_QuestionUP2.rar

فورم بيان موظفين مع الصور ب MultiPage الفيديو

تفضل الملف جاهز MAGAZIN.xlsx

السلام عليكم اخي العزيز اصبح التركيز (SetFocus) على هذا الحقل ويمكن تغييره بعدة طرق منها: 1- عن طريق ترتيب الجدولة. اضغط بزر الماوس الايمن في مكان فارغ بالنموذج في طريقة عرض التصميم(كما في الصور) : 2- عن طريق الكود البرمجي. كما في الملف المرفق (يوجد نموذجين بالملف احدهما افتراضي والاخر برمجي) Me.[اسم الحقل].SetFocus test.rar

الاخ فارس النايلي ملاحظة قبل تنفيذ التجميع : يجب ان يكون ملف التجميع موجود في نغس فلدر ملفات المصدر وسوف يقوم ملف التجميع بتجميع كل شيتات ملفات المصدر الموجودة في نغس الفولدر شاهد المرفق My_Folder_Xlsm.rar

ومشاركه مع اخوانى بداله Dcount مع التاريخ محاوله منى على قدى بالتوفيق اخى نظام وارد-1.accdb

السلام عليكم 🙂 في تعديل بسيط عملته ، وارفقته في مشاركتي الاخيرة اللي فيها مرفق 🙂 جعفر

ممكن تبدليه بهذا الكود Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select ElseIf Target.MergeCells = True And Target.HasFormula = True Then Target.Offset(0, 1).Select ElseIf ActiveCell.HasFormula = True And ActiveCell.MergeCells = True Then ActiveCell.Offset(0, 1).Select End If End Sub و بعذ إذن أستاذنا الفاضل سليم أرى أن يكون التعديل هكذا اكتب في السطر الذي قبل كلمة Dim في الماكرو ActiveSheet.Unprotect "123" واكتب في السطر الذي قبل كلمة End sub ActiveSheet.Protect "123" Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False ActiveSheet.Unprotect "123" Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True ActiveSheet.Protect "123" End Sub My_students (1).xlsm

وعليكم السلام ورحمة الله وبركاته ارفق مثال اخي الكريم لفهم المطلوب ولك الشكر تحياتي

وعليكم السلام و رحمة الله و بركاته لان نموذجين الفرعي و رئيسي مربوطين بعلاقة عمودين id و Title احذف علاقة Title و تنحل المشكلة بإذن الله

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

بعد اذن اخى واستاذى @د.كاف يار اتفضل اخى وبالتوفيق ان شاء الله Pupil Names_UPDate.accdb

السلام عليكم ورحمة الله اجعل هذا السطر هكذا Sheets("سجل الصادر").Cells(EndRow + 1, 1).Value = EndRow - 1

الله الله عليك استاذنا الفاضل / @essam rabea كود جميل جدا جدا الله يفتح عليك ويجزاك خير الطريقة ليست قديمة بل احدث من الحديث

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

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

بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد

لمراعاه كافة الاحتمالات لكون معيار التاريخ يتأثر بطريقة الكتابة واسلوب التاريخ في النظام بالتوفيق اخي ليث والشكر لله سبحانه

تم تحرير كود لهذا الغرض Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A4").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 .Value = .Value End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("a" & MM).Interior.ColorIndex <> xlNo Then If color_rg Is Nothing Then Set color_rg = Range("a" & MM).Resize(, 6) Else Set color_rg = Union(color_rg, Range("a" & MM).Resize(, 6)) End If End If Next color_rg.Copy Range("a" & nro + 1) color_rg.EntireRow.Delete Range("A4", Range("A3").End(4)).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" Range("A3").CurrentRegion.Value = _ Range("A3").CurrentRegion.Value Range("A4").Select Set color_rg = Nothing Application.ScreenUpdating = True End Sub الملف من جديد M_data_new_SA.xlsm

السلام عليكم هذا ملف فيه كود تنبيه TIMER يظهر لك وميض للتنبيه قبل 5 ايام وكذلك بعد 5 ايام من انتهاء المدة (ويمكن تغيير المدة حسب العمل)) ويمكن اظافة رسالة تنبيه له تحياتي test.rar

الاستاذ الفاضل / @ adnan gharbi دعنى اهمس فى اذنك : المنتدى هنا ملئ بالخبرات الكثيرة وكلهم لم يتأخروا في مساعدتك ومساعدة الاخرين وكل الاخوان اي سؤال لك او اى موضوع اطرحه بهدوء بشرط ان يكون فى شكل مثال مبسط والمطلوب يكون واضح ولا يكون اكثر من سؤال حتى يتسنى لهم وحسب اوقاتهم الاجابة جرب وشوف ان شاء سوف تتعلم هنا كل شئ كل التوفيق والنجاح

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

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

بعد إذن أخى وحبيبى أحمد الفلاحجى أ.romeo4 جرب المرفق عسى أن يكون المطلوب للجمع(2).accdb

DoCmd.TransferDatabase acImport, "Microsoft Access", مسار قاعدة البيانات المستورد منه, acQuery, "اسم الاستعلام في الملف المستورد منه", "اسم الاستعلام بعد الاستيراد", False تفضل ....

وعليكم السلام-اهلا بك بالمنتدى -تفضل فقط بهذه المعادلة =IF(A2="","",A2+(((((D2/30)/12+(C2/12)+B2)))*354)) او جرب هذا الرابط https://www.officena.net/ib/topic/50355-اضافة-اشهر-الى-التاريخ-الهجري/page/2/ 103.xls

أ.AhmedEmam جرب المرفق عسى أن يكون المطلوب بالتوفيق Increase TextBox.accdb

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

السلام عليكم جرب الحل في الملف المرفق... تجميع اعمدة.xlsx

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

جرب هذا الملف الكود يعمل في النطاق من A1 الى A10 (اللون الأصفر) الكود Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A1:A10")) Is Nothing _ And Target.Count = 1 Then Range("B1:B10").ClearContents Target.Offset(, 1) = Range("F1") End If Application.EnableEvents = True End Sub الملف مرفق Writ in Offset.xlsm

أستاذ يوسفي أين الضغط على الإعجاب ؟!💙

هل مواد الدين والرياضيات من ضمن ملفات الاكسل الجديدة الموجودة في الموضوع ... ما نوع الاوفيس لديك بعد تعديل اسم الملف حاول تشغيل البرنامج واستيراد البيانات مره اخرى

1-لا تجعل الخلية L1 فارغة ولا تحتوي على اسم اي شيت 2-اذا كان النطاق من L2 و نزولاً فارغاً الكود يأخذ كل الصفحات وإلا الصفحات المحددة في هذا النطاق 3-عدم ترك خلايا فارغة بين اسماء الشيتات المطلوبة في العامود L تفضل الكود المطلوب Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim ACT_Ro% 'Actual row All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) Dim Mon_Array SH.Range("A4:F" & Rows.Count).Clear Set Principal = Sheets("serch") Mon_Array = Application.Transpose(Range("L2", Range("L1").End(4))) If UBound(Mon_Array) > Sheets.Count Then For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop Next_sh: Next Else '================================================ For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh1 If Application.CountIf(Principal.Range("L2:L50"), SH.Name) <> 0 Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh1 Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop End If Next_sh1: Next '==================================== End If If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:F" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Saerch_by_Special_sheets.xlsm

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

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

جرب المرفق تنسيق شرطي بعد استخلاص اسم الدولة من القائمة المنسدلة عن طريق مربع نص غير مرتبط وقيمة المربع تساوي =qsplit([العنوان];0) example.accdb