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

سلمك الله من كل شر .. شكرا ابو زاهر .. صدقت

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

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

استأذن من استاذنا ابو خليل يعني هذا ما تريده لانك كتبت هذا اتفضل اليك ما طلبت Private Sub barcod_DblClick(Cancel As Integer) Static i, NewBarcod, OldBarcod OldBarcod = Me.barcod If IsNull(barcod) = True Then i = 0 ElseIf NewBarcod = OldBarcod Then i = i + 1 Else i = 1 End If NewBarcod = Me.barcod ss = i End Sub sami.accdb

السلام عليكم بعد إذن أخونا عماد تفضل أخي طارق بالملف المرفق المساحة الصفراء (H9:H17) إذا فيها خلايا ليست فارغة سيضيف لها كومنت "XX" الكومنت يختفي بعد الإضافة الكود في حدث تغيير الإختيار للورقة أي أنه يتم تفعيله أوتوماتيكيا بمجرد تغيير الإختيار داخل الورقة ويقوم بعمل مراجعة للمساحة الصفراء إذا فيها خلايا ليست فارغة سيضيف لها كومنت وإذا فيها خلايا فارغة سيتم حذف الكومنت Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, [H9:H17]) Is Nothing Then Exit Sub For Each c In [H9:H17] If IsEmpty(c) = True Then c.ClearComments: GoTo 10 c.AddComment ("XX") c.Comment.Visible = False 10 Next c End Sub Add comment.xlsm

اتفضل هذا ماكرو لاستاذى الجليل ومعلمى القدير الاستاذ @ابوخليل وقمت بالتعديلات الطفيفه عليه باضافة ماكرو لمنع الكليك يمين على التقرير منع النسخ.mdb

عليكم السلام اذا تقصد قاعدة الجداول .. من الطرق .. عمل فورم يعمل بالخفاء ويفتح آليا عند فتح جهاز الكمبيوتر

شكرا استاذ @ابو ياسين المشولي من الاحسن ان تكتب ما تعمله لكي من يرى المشاركة قبل ان ينزل المرفق يعرف ماذا بداخله وراح نستفيد منه باسرع وقت ممكن وحلولك مظبوطة 100% ونقدر عند الضغط الزر ان نعطيه الشروط هكذا بدل ان تكتبه عند فتح التقرير DoCmd.OpenReport "Sersh_rpt", acViewReport, , "Left(Nz([ItemName],0),50) Like '*' & [Forms]![Sersh_F]![n1] & '*'" وشكرا لك

نعم لا اظن ان هذه الطرائق صعبة ... خاصتا طريقة ديماكس + 1 او الطريقة استاذ @Khalf كل شيء عنده طرائقه الحمد لله ممكن تشوفنا ما هي طريقتك لكي نعلم ماذا تريد بالضبط لا داعي تحياتي

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

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

كيف نجعل الخلية تتمرد على تحديدها و تنتقل مع محتوياتها الى العامود المجاور(هروباً من التحديد) شاهد هذا الملف Go_Away.xlsm

أمامنا جدول مع بيانات مختلفة 1- انقر على اي خلية من الجدول (ما عدا رأس الجدول) لتحصل على فلتر بقيمة هذه الخلية 2-انقر على اي خلية ( من رأس الجدول) لتحصل على كل البيانات 3-لإضافة بيانات على الجدول انقر على اول صف فارغ وأملأ الصف كما تشاء (لا يعمل الماكرو الا اذا كان الصف كاملاً ببياناته 4 قيم) ملاحظة: لا يعمل الماكرو Reset ولا الماكرو Make_On_Top كل بمفرده الا من خلال الماكرو الرئيسي SelectionChange الماكرو Option Explicit Dim Lr%, Rng As Range '========================== Sub Make_On_Top() On Error GoTo Exit_Sub Rng.Rows(1).Interior.ColorIndex = 6 With ActiveSheet .Range("z1") = Cells(3, ActiveCell.Column) .Range("z2") = ActiveCell.Value .Range("a3").CurrentRegion.AdvancedFilter 1, Range("z1:z2") .Cells(3, ActiveCell.Column).Interior.ColorIndex = 8 End With Exit_Sub: End Sub '================================== Sub Reset() On Error GoTo Exit_Sub Rng.Rows(1).Interior.ColorIndex = 6 On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Exit_Sub: End Sub '=========================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Lr = Cells(Rows.Count, 1).End(3).Row Set Rng = Range("A3:D" & Lr) If Not Intersect(Target, Rng) Is Nothing And _ Application.CountA(Range(Cells(Target.Row, 1), _ Cells(Target.Row, 4))) = 4 _ And Target.Cells.Count = 1 Then If Target.Row = 3 Then Reset Else Make_On_Top End If End If Range("z1:z2").Clear End Sub الملف مرفق Super Adv_Filter.xlsm

بارك الله فيك اخى ابو زاهر

اتفضل تم استخدام الكود في هذا الرابط لعمل نسخة احتياطي و ضغط و اصلاح وهذا هو الكود في وحدة النمطية Option Compare Database Public Function BackUpMyDb() Dim MyPath As String, math1 As String, math2 As String math1 = CurrentProject.Path math2 = math1 & "\MyProg" MyPath = math2 & "\BackUpSaved" On Error GoTo MyErr Dim OldFile, DBwithEXT, DBwithoutEXT, NewFile, CopyMyDB, TypeApp OldFile = CurrentDb.Name DBwithEXT = Dir(OldFile) If Right(DBwithEXT, 5) = "accdb" Then DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 6) TypeApp = ".Accdb" ElseIf Right(DBwithEXT, 3) = "Mdb" Then DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4) TypeApp = ".Mdb" End If If Dir(math2, vbDirectory) = "" Then MkDir math2 If Dir(MyPath, vbDirectory) = "" Then MkDir MyPath NewFile = MyPath & "\" & DBwithoutEXT & "-" & Format(Now, "yyyy-mm-dd-Hh-Nn-Ss") & TypeApp CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MyErr: If Err.Number <> 0 Then MsgBox Err.Number & " - " & Err.Description End If End Function Public Function compactDb(ByVal mydb As String, ByVal mypass As String, Optional openIt As Boolean = False) Dim F As Integer Dim filenoext As String, extension As String, Access As String Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE""" filenoext = Left(mydb, InStrRev(mydb, ".")) extension = Right(mydb, Len(mydb) - InStrRev(mydb, ".")) F = FreeFile Open CurrentProject.Path & "\compact.bat" For Output As F 'wait until the Db closes (ldb file is gone), then compact it Print #F, "CHCP 1256" Print #F, ":checkldb1" Print #F, "if exist """ & filenoext & "l" & extension & """ goto checkldb1" Print #F, Access & " """ & mydb & """" & mypass & " /compact" If openIt Then 'wait until the Db closes, then start it Print #F, ":checkldb2" Print #F, "if exist """ & filenoext & "l" & extension & """ goto checkldb2" Print #F, Access & " """ & mydb & """" Else Print #F, "del ""%~f0""" End If Close F End Function Public Function CopactMyDb() On Error Resume Next Dim MyPath As String MyPath = CurrentProject.Path & "\" & CurrentProject.Name Call compactDb(MyPath, "", True) Shell """" & Left(MyPath, InStrRev(MyPath, "\")) & "\compact.bat""", 0 DoCmd.Quit acQuitSaveAll End Function وفي نموذج عند تايمر تم استخدام هذا الكود Option Compare Database Private Sub Form_Open(Cancel As Integer) Me.TimerInterval = 1000 End Sub Private Sub Form_Timer() Me.MyOclock.Caption = Time If Time = #3:00:00 PM# And Weekday(Date) = 2 Then Call BackUpMyDb: Call CopactMyDb End Sub وتقدر تغير ساعة او اليوم للتجربة عليه للعلم ليوم الاحد رقم 1 الاثنين رقم 2 الثلاثاء رقم 3 الاربعاء رقم 4 الخميس رقم 5 الجمعة رقم 6 السبت رقم 7 لكن يجب ان يكون النموذج مفتوحة في ذلك الوقت ولكن حسب رأيي الرابط الاعلاه راح تستفيد منه اليك القاعدة compactInClose (1).accdb

عفواً أخي ابو زاهر أشكرك على الرد ولكن انا استخدم اوفيس2003 ولا يوجد عندي هذا الخيار ( لون المرور )

هل هذا ينفع لا اعلم ما هو البطى ولكن لعل بيكون اسرع في وحده نمطيه وضعت لك الكود UPdate QTY.accdb

مشاركه مع الاخ ابو زاهر شوف هذا تحديث الكميه.accdb

مشكور اخي

على الرحب والسعه الكود بيكون بهذا الشكل بالنموذج DoCmd.OpenReport "Sersh_rpt", acViewReport, , "Left(Nz([ItemName],0),50) Like '*' & [Forms]![Sersh_F]![n1] & '*'"

الله يسلمكم @ابو ياسين المشولي@qathi

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

العفو اخي بارك الله فيك ان شاء الله يكون كما طلبت

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

أخى الكريم لماذا لا تستخدم خاصية البحث فى المنتدى قبل رفع المشاركة فهناك موضوع مهم جدا عن ذلك الغرض لأستاذنا الكريم سليم حاصبيا وبه ملف ممتاز -وموجود هنا : https://www.officena.net/ib/topic/84508-حماية-الخلايا-غير-الفارغة-بواسطة-باسوورد/?tab=comments#comment-536608

وعليكم السلام المطلوب فيه غرابة !!! كيف عند الانتقال يبدأ العد من جديد ، هذا يعني انه يستمر يسجل الرقم 1 وهذا بالضبط مايدل عليه العنوان : عند الانتقال للسجل التالي يبدا حقل العدد بالعد من جديد اي من رقم 1 هل تريد الاستمرار بتسجيل الرقم 1 ؟ ام تقصد ان العدد عند الانتقال يستمر بالزيادة ؟ ، وضح ما تريد مفصلا

الحمد لله .. وشكرا على دعواتك الطيبات .. ولك اخي بمثل ما دعوت ..

اعتقد ليس هذا المكان المناسب للموضوع ساعدينا في البحث عن المنتدى المناسب داخل الموقع كي ننقله اليه واكتفي بتعديل العنوان ..

اخي ali mohamed ali السلام عليكم ورحمة الله وبركاته تمام جدا ـ الله ينور عليك ويبارك لك ويوفقك

السلام عليكم عذرا أخي الكريم (علي) الملف الذي أرفقته لم تضف له شيئا (من الممكن أنك نسيت حفظ التعديلات) أخي الكريم (محمد) تفضل الملف به المعادلات المعدلة باللون الأحمر والخلايا الصفراء بها المعادلات لكن قيمتها فارغة حيث انتهي عدد الأقساط هل هذا ماتريد اقساط معدل1.xlsm

ا نت طلبت ذلك من خلال قولك محتاج طريقه لترتيب الارقام عشوائي شرح عمل الكود: ======================================================= الكود يأخذ مجموعة عشوائية محددة (حسب الطلب ) من الاعداد بين عددين ومن ثم يرتبها تصاعديا مثلاُ بين 50 و 500 المطلوب 5 أعداد احد النتائج المحتملة (من بين ألوف الألوف) 350 425 100 260 61 الكود يكتبها هكذا : 61 100 260 350 425 هنا ليس ترتيب لارقام متسلسلة بل ترتيب تصاعدي لارقام عشوائية للمزيد يرجى الاطلاع على هذا الملف في العنوان التالي: https://www.officena.net/ib/topic/85730-كيف-نختار-مجموعة-عشوائية-من-التلاميذ/ =================================================================== اذا كنت لا تريد الترتيب احذف او ( علّق) السطر الرابع من الاسفل من الكود ليصبح هكذا Option Explicit Sub Sorting_Rand_Numbers() Dim i%, k% Dim myStart%: myStart = Application.Min([c2], [d2]) Dim myEnd%: myEnd = Application.Max([c2], [d2]) Dim a() Range("b:b").ClearContents Dim x: x = [e2] If Not IsNumeric(x) Or IsEmpty(x) Then _ MsgBox "Wrong input in $E$2": Exit Sub If x < 1 Or Int(x) <> x Or x > myEnd - myStart + 1 Then x = myEnd - myStart [e2] = x End If ReDim a(myEnd - myStart) With CreateObject("System.Collections.SortedList") Randomize For i = myStart To myEnd .Item(Rnd) = i Next i For i = 0 To .Count - 1 a(i) = .GetByIndex(i) Next End With With Range("b2") .Resize(UBound(a) + 1).Value = Application.Transpose(a) .Offset(x).Resize(myEnd - myStart + 1 - x).ClearContents ' .Resize(x).SortSpecial End With Erase a End Sub

شوف جرب هذا ووافني بالنتيجة البديهي ان المسؤول عن الحسابات سوف يستخرج الاهلاك من التملك الى نهاية السنة الحالية ehlakAlosol_3.rar

قبل الان انا رديت عليك هكذا والان عملت لك هذا test 15 (1).rar

السلام عليكم و رحمة الله و بركاته لاشك ان عمل استاذ شفان يستحق المدح وحبيت اضافة بسيطه الا وهو تحديد و تصدير اكثر من حقل في وقت واحد المثال: test 15.zip

هذا جيد لكي لا يشتغل على اي جهاز الا ان تعطيه رمز التسجيل وهذا ايضا جيد على الرغم ان هناك برامج لكي يلغي هذا الامر وهذا احسن اذا لا تريد ان تتحول الملف الى Accde او Mde وهذا جيد لكن حاله مثل حالة شيفت :) هذا يكفي مع الرقم الاول والثاني من زمان انا ما استخدمت هذا هناك شيء اخر مع نقطة الاول اي ربط عمل ملف مثل تيكست في احد الاماكن في الجهاز بشكل سري اي اذا فتحت البرامج وما وجدت هذه الملف سيغلق البرامج والا سيفتح اذا تم تسجيله من قبل و هناك طريقة اخرى وهو تشفير البيانات بدل اخفاء الجداول لكن هذه شيء سيبطي العمل وفي الاخير 1 و 2 و 5 و اذا تريد 6 يكفي حسب رأيي

كان عندك مشكله بالعلاقات مش مربو ط برقم الفاتوره والتسميه حطاء بالنموذج انظر لهذا ان شاء الله يكون مطلوبك الحفظ 2التلقائي.accdb

اتفضل اخي رمهان رمهان.accdb

اتفضل من امس وانا افكر لك DoCmd.ApplyFilter "", "Left(Nz([ItemName],0),50) Like '*' & [Forms]![Sersh_F]![n1] & '*'"

أهلا بك محمد لطفي.. هل تريد عمل شئ آخر غير إظهار الصفحة؟ كهربا (1).mdb

رداً على سؤال حارثة ابو زيد يلزم وقتها هذا الكود Option Explicit '============================== Sub colorize_ALL() Dim x%, k%, i%, m% Dim MY_St1$, MY_St2$, find_txt$ Dim My_Txt Dim Last_Row%: Last_Row = Cells(Rows.Count, 1).End(3).Row If Last_Row < 2 Then Last_Row = 2 MY_St2 = UCase(Range("c2")) Application.ScreenUpdating = False For i = 2 To Last_Row MY_St1$ = UCase(Range("a" & i).Value) With Range("a" & i).Font .ColorIndex = 0: .Underline = False: .Italic = False: .Bold = False End With '================================== For m = 1 To Len(MY_St1) - Len(MY_St2) + 1 find_txt$ = Mid(MY_St1, m, Len(MY_St2)) If find_txt$ = MY_St2 Then With Range("a" & i).Characters(m, Len(MY_St2)).Font .ColorIndex = 3: .Underline = True: .Italic = True: .Bold = True k = k + 1 End With End If Next m i = i + Range("a" & i).MergeArea.Rows.Count - 1 Next i Select Case k Case 0: Range("b2") = "Nothing similar" Case Else: Range("b2") = "There are: " & Chr(10) & k & " Expressions" End Select If k = 1 Then Range("b2") = Mid(Range("b2"), 1, Len(Range("b2")) - 1) Exite_Me: Application.ScreenUpdating = True End Sub الملف مرفق (مغ بعض الشرح في الورقة Sheet1) Full_Saerch_expressions.xlsm

أخي العزيز قم بانشاء تقرير بالتصميم الذي تريده و اجعل الجدول مصدر السجلات للتقرير ، Rep1 قم بانشاء زر أمر في النموذج وخلف حدث عند النقر أنقل الكود التالي If Me.FilterOn And Len(Me.Filter & "") > 0 Then DoCmd.OpenReport "rep1", acViewPreview, WhereCondition:=Me.Filter Else DoCmd.OpenReport "rep1", acViewPreview End If افتح النموذج وقم بعملية الفلترة و اضغط زر الامر الخاص بالطباعة ، اذا طلبت الطباعة بدون فلترة يكون مصدر السجلات للتقرير الجدول كاملا و انتظر منك دعوة طيبة بظهر الغيب والله من وراء القصد مرفق تطبيق معدل لقاعدة بياناتك شكرا Up_NA_PrintFilter.accdb

اخوتي اعضاء المنتدى كما يعلم الجميع فإنه يتم الحكم على كفاءة اي برنامج من خلال مخرجاته أي تقاريره ومن يعمل في اكسس يلاحظ جمود تقاريره مقارنة بتقارير اكسل لذا فقد اخذت الكثير من الوقت في تصميم تقارير مرنة تشمل اهم الافكار المطلوبة في التقرير وكنت قد وضعتها في تقرير واحد بهدف رفعه للمنتدى ولكني رأيت ان ذلك يمكن ان يصعب على الأعضاء فهم الطريقة . لذا قررت ان اجعل المثال يحتوي على تقريرين . الأول : يوضح طريقة رسم الحدود وتحديد سجلات الصفحة والإقفال بعد آخر سجل . الثاني : يشمل جميع الأفكار . أرجو أن ينفع الله بهذا المثال كل طالب علم ... ملحوظة : المثال يحتوي على 80 سجل وتم تحديد عدد سجلات الصفحة 20 سجل لذا عند فتح التقرير سيطلب منك تحديد عدد السجلات المطلوبة لذا للتعرف على المثال بشكل واضح جرب تحديد عدد (5 و 20 و 21 و 40 و 45) على التوالي ولاحظ كيف سيظهر التقرير في كل مرة اسأل من الله الأجر والدعاء من كل من إستفاد من هذا العمل تحياتي,,, التقارير.rar

الاصدار الاخير بعد اضافة نسخ احتياطي و تقسيم القاعدة والملفات وتعديل الطابعة وحدود الطباعة واضافة خانات العملة والحساب التلقائي ارجو التجريب والرد AMS.rar

أخي العزيز : هذه الرسائل تظهر في العادة عندما يكون هناك بعض العناصر المتعلقة بما يسمى عناصر الـ ActiveX Control و هي عناصر يجب ان تكون موجودة على المسار التالي : C:\WINDOWS\system32 فمثلاً إذا كنت تستخدم ضمن برنامجك CommonDialog فيجب أن يتوفر العنصر التالي comdlg32.dll على المسار المشار إليه أعلاه وغير ذلك سوف لن تتمكن من إستخدام هذه الخاصية ضمن برنامجك على الأجهزة التي لا يتوفر بها هذا المرجع . الحل : يوجد حل لهذه المشكلة وهو أن تقوم بتنزيل Service Pack للأوفيس أو تنزيل عناصر الـ Active X Control .