اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


Popular Content

Showing content with the highest reputation since 22 ديس, 2019 in all areas

  1. 6 points
    وعليكم السلام ورحمه الله وبركاته اخى الفاضل اهلا ومرحبا بك معنا فى منتدى الاكسيس ارجو منك الا تغضب من كلامى اخى الفاضل ان المنتدى تعليمى وليس لانشاء برامج كامله للاعضاء اى تبدا بالتعلم وانشاء برنامجك وحين تتوقف فى نقطه معينه تسال واخوانك واساتذتنا لايقصرون جزاك الله خيرا على كل ما تقوم به من اجل مساعده اخوانك تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق
  2. 5 points
    جرب الكتابة داخل المربع الأول وانظر النتيجة .... ايقاف علامة جدولة.accdb
  3. 5 points
  4. 5 points
    كل عام وجميع الاخوة بالمنتدى بالف خير من الجميل ان نبدأ العام بتهنئة بكود اكسس تحياتي للجميع test.rar
  5. 5 points
  6. 4 points
  7. 3 points
    جرب هذا الماكرو 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
  8. 3 points
    السلام عليكم ورحمة الله وبركاته وبعد ... عزيزي العضو السائل عن الشريط الموجود بالبرنامج الموضح صورته بالمشاركة الأولى ... الحل بسيط جدا هو أن يكون لديك نسخة من البرنامج من إصدار أوفيس إكس بس أو 2003 وتعمل عليها شريط القوائم المطلوب ومن ثم تقوم باستيراد كل الكائنات للقاعدة من البرنامج الذي تعمل عليه ومن ثم تحويله للعمل على أي إصدار أحدث ...ففي القاعدة المرفقة لاحظ القوائم ولا يوجد أي نماذج لأن هذه هي القاعدة الفارغة التي أحتفظ بها بإصدار قديم mdb أقوم بفتحها على الأوفيس إكس بي وأقوم باستيراد النموذج أو التقرير الذي أحتاج ربطه على شريط القوائم كما ترى في الصورة بمسمى محدد ثم أقوم بحفظ الملف ونسخه وتسميته بأي إسم آخر غير القاعدة التي أخصصها لعمل شريط القوائم ثم أقوم بفتح الملف الجديد بأي اصدار حديث و أقوم باستيراد كل محتويات الملف الأصلي للبرنامج ثم أقوم بحفظه بأي صيغة أحتاجها سواء مفتوحة أو مغلقة كما ترى في الصورة التالية ويمنني معاونة حضرنك في عمل شريط قوائم للبرنامج الخاص بك بشرط إرسال البرنامج في صيغة mdb وبيان بالشريط كما تتخيله وحاضرين سيتم تلبية طلبك ولو شئت ممكن المراسلة على الخاص لحفظ حقوق تصميمك و جزاكم الله خيرا
  9. 3 points
    وعليكم السلام-كلن عليك استخدام خاصية البحث بالمنتدى-تفضل طلب هل من طريقة لعمل زر متحرك مع صفحة
  10. 3 points
    اهلا بك بالمنتدى عليك فقط بالضغط على أيقونة إظهار الفورم أنا أعمل على اكسيل 2010 ولكن عليك بعمل ما تريد من زر او ايقونة وعليك بربطها بهذا الكود وذلك من خلال فتح مديول جديد ولصق هذا الكود به Sub Show() Application.Visible = False UserForm1.Show End Sub 1رصد.xlsm
  11. 3 points
  12. 3 points
    جربي المرفق 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
  13. 3 points
    انتظرت ردك اخي الكريم فان كنت تقصد تحديد الاسم الاول في القائمة عن الضغط على الزر فاليك الامر التالي Me.txtliste3.Selected(0) = True تحياتي
  14. 3 points
    اتفضل شوف المثال التالى ان شاء الله يفيدك وجزاه الله خيرا استاذ محمد ندا كان فى مثال تانى عندى لام عهود بس مش لاقيه حاليا هدور عليه تانى تقبل تحياتى بالتوفيق _ترقيم غير تلقائى بنطاقات متعددة بنفس الجدول خمس شركات فى جدول واحدNumering_QuestionUP2.rar
  15. 3 points
    فورم بيان موظفين مع الصور ب MultiPage الفيديو
  16. 3 points
  17. 3 points
    السلام عليكم اخي العزيز اصبح التركيز (SetFocus) على هذا الحقل ويمكن تغييره بعدة طرق منها: 1- عن طريق ترتيب الجدولة. اضغط بزر الماوس الايمن في مكان فارغ بالنموذج في طريقة عرض التصميم(كما في الصور) : 2- عن طريق الكود البرمجي. كما في الملف المرفق (يوجد نموذجين بالملف احدهما افتراضي والاخر برمجي) Me.[اسم الحقل].SetFocus test.rar
  18. 3 points
    الاخ فارس النايلي ملاحظة قبل تنفيذ التجميع : يجب ان يكون ملف التجميع موجود في نغس فلدر ملفات المصدر وسوف يقوم ملف التجميع بتجميع كل شيتات ملفات المصدر الموجودة في نغس الفولدر شاهد المرفق My_Folder_Xlsm.rar
  19. 3 points
    ومشاركه مع اخوانى بداله Dcount مع التاريخ محاوله منى على قدى بالتوفيق اخى نظام وارد-1.accdb
  20. 3 points
    السلام عليكم 🙂 في تعديل بسيط عملته ، وارفقته في مشاركتي الاخيرة اللي فيها مرفق 🙂 جعفر
  21. 2 points
    ممكن تبدليه بهذا الكود 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
  22. 2 points
    وعليكم السلام ورحمة الله وبركاته ارفق مثال اخي الكريم لفهم المطلوب ولك الشكر تحياتي
  23. 2 points
    وعليكم السلام و رحمة الله و بركاته لان نموذجين الفرعي و رئيسي مربوطين بعلاقة عمودين id و Title احذف علاقة Title و تنحل المشكلة بإذن الله
  24. 2 points
    تم التعديل عند فتح الملف خاصية ( الأزار المتحركة تكون فعله وخاصية ( طباعه الخلايا المحددة بالماوس فقط ) تكون معطله عندما تريد استخدام خاصية ( طباعه الخلايا المحددة بالماوس فقط ) قم بتفعيل ( تشك بوكس ) بنفس الشت شاهد المرفقات Test_3.rar بإذن الله سأحاول عمل ذلك لكن ما هي الورقة المعنية بتلك المهمة ( الرورقة التي تعطينا منها الرقم )
  25. 2 points
    بعد اذن اخى واستاذى @د.كاف يار اتفضل اخى وبالتوفيق ان شاء الله Pupil Names_UPDate.accdb
  26. 2 points
    السلام عليكم ورحمة الله اجعل هذا السطر هكذا Sheets("سجل الصادر").Cells(EndRow + 1, 1).Value = EndRow - 1
  27. 2 points
    الله الله عليك استاذنا الفاضل / @essam rabea كود جميل جدا جدا الله يفتح عليك ويجزاك خير الطريقة ليست قديمة بل احدث من الحديث
  28. 2 points
    العفو اخى والشكر لله ثم لاخواننا واخواتنا واساتذتنا جزاهم الله خيرا بمعنى ايه ؟ يظهر كافة التقارير فهل استطيع التعديل عليه حيث انه يعرض ما اريده منه فقط ؟ المثال يفتح كل تقرير يتم اختياره لعلى لم افهم المطلوب ممكن توضح اكتر اخى وان شاء الله احاول اساعدك او احد اخواننا واساتذتنا يساعدك تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق
  29. 2 points
    فورم اظهار الادخال الجديد للاسم على الليست بوكس بمجرد الحفظ الفيديو
  30. 2 points
    بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد
  31. 2 points
    لمراعاه كافة الاحتمالات لكون معيار التاريخ يتأثر بطريقة الكتابة واسلوب التاريخ في النظام بالتوفيق اخي ليث والشكر لله سبحانه
  32. 2 points
    تم تحرير كود لهذا الغرض 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
  33. 2 points
    السلام عليكم هذا ملف فيه كود تنبيه TIMER يظهر لك وميض للتنبيه قبل 5 ايام وكذلك بعد 5 ايام من انتهاء المدة (ويمكن تغيير المدة حسب العمل)) ويمكن اظافة رسالة تنبيه له تحياتي test.rar
  34. 2 points
    الاستاذ الفاضل / @ adnan gharbi دعنى اهمس فى اذنك : المنتدى هنا ملئ بالخبرات الكثيرة وكلهم لم يتأخروا في مساعدتك ومساعدة الاخرين وكل الاخوان اي سؤال لك او اى موضوع اطرحه بهدوء بشرط ان يكون فى شكل مثال مبسط والمطلوب يكون واضح ولا يكون اكثر من سؤال حتى يتسنى لهم وحسب اوقاتهم الاجابة جرب وشوف ان شاء سوف تتعلم هنا كل شئ كل التوفيق والنجاح
  35. 2 points
    أ.عزالدين المنصوري الفكرة وصلت تمام ولكن أين المرفق الذى سيتم التطبيق عليه؟؟
  36. 2 points
    جزاك الله خيرا / استاذي ومعلمى / @kha9009lid اكرمك الله وزادك اخلاقا فأنت قمة الاخلاق لكى تسأذن من احد تلاميذك اذا حضر الماء بطل التيمم استاذ / عدنان الله يكرمك لعلك تكون وصلت الى مبتغاك
  37. 2 points
    بعد إذن أخى وحبيبى أحمد الفلاحجى أ.romeo4 جرب المرفق عسى أن يكون المطلوب للجمع(2).accdb
  38. 2 points
    DoCmd.TransferDatabase acImport, "Microsoft Access", مسار قاعدة البيانات المستورد منه, acQuery, "اسم الاستعلام في الملف المستورد منه", "اسم الاستعلام بعد الاستيراد", False تفضل ....
  39. 2 points
    وعليكم السلام-اهلا بك بالمنتدى -تفضل فقط بهذه المعادلة =IF(A2="","",A2+(((((D2/30)/12+(C2/12)+B2)))*354)) او جرب هذا الرابط https://www.officena.net/ib/topic/50355-اضافة-اشهر-الى-التاريخ-الهجري/page/2/ 103.xls
  40. 2 points
    أ.AhmedEmam جرب المرفق عسى أن يكون المطلوب بالتوفيق Increase TextBox.accdb
  41. 2 points
    السلام عليكم ورحمة الله وبركاته فكرة قمت بتجميها من عدة افكار لعمل قائمة منسدلة متغيرة حسب معطيات جدول يحتوي على خواص بحث احببت مشاركتها معكم ارجو ان تكون بها فائدة لكم مني فائق الشكر والتقدير معادلة جدول الحصص.xlsx
  42. 2 points
    السلام عليكم جرب الحل في الملف المرفق... تجميع اعمدة.xlsx
  43. 2 points
    وعليكم السلام ورحمه الله وبركاته مجرد فكره اجعله حقل نصى عادى ثم عند الخروج من الحقل او حدث بعد التحديث استخدم الخاصيه format فى محرر الاكواد لجلعه بتنسيق التاريخ تقبل تحياتى
  44. 2 points
    جرب هذا الملف الكود يعمل في النطاق من 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
  45. 2 points
    أستاذ يوسفي أين الضغط على الإعجاب ؟!💙
  46. 2 points
    هل مواد الدين والرياضيات من ضمن ملفات الاكسل الجديدة الموجودة في الموضوع ... ما نوع الاوفيس لديك بعد تعديل اسم الملف حاول تشغيل البرنامج واستيراد البيانات مره اخرى
  47. 2 points
    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
  48. 2 points
    بعد اذن الاخوه الاعزاء تعتبر الحماية برقم البارتشن غير مجدية في حالة القيام بفرمتة بارتشن C والافضل الحماية بالسريال نمبر الحقيقي للهارد ديسك سوف ابحث في ملفاتي عن كود استخراج سريال نمبر الحقيقي للهارد ديسك واذا وجدته سأضعه هنا ليستفيد الجميع منه ولي موضوع قديم بهذا الصدد بالمنتدي ولكن لا اتذكر الرابط او العنوان
  49. 2 points
    مرحبتين فيك أخونا الكريم عبدالاله عليك البدء خطوة خطوة وأي مشكلة تواجهها ستجد حلها هنا بإذن الله .. الاكسس يعتبر واحد من اسهل لغات البرمجة لعمل برامج كل ماعليك فعله هو ان تضع فكرة بسيطة لتنفيذها مثلاً فكرة عمل تخزين بيانات الموظفين ومن ثم الاستعلام عن بيانات اي موظف تريد عن طريق نموذج بحث بسيط وبعدها تستطيع تطوير برنامجك خطوة بخطوة وتعلم مهارات وافكار عديدة من خلال هذا المنتدى الذي يضم عمالقة وخبرات كبيرة لايستهان بهم مستعدين للإجابة على جميع التساؤلات إن شاء الله تحياتي
  50. 2 points
    جرب المرفق تنسيق شرطي بعد استخلاص اسم الدولة من القائمة المنسدلة عن طريق مربع نص غير مرتبط وقيمة المربع تساوي =qsplit([العنوان];0) example.accdb


×
×
  • اضف...