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

السلام عليكم كل شيء عندك تمام إلا جدول Teacher غير حقل Email إلى مطلوب من نعم إلى لا فقط راح تضبط معك بإذن الله تعالى .

وعليكم السلام-بعد اذن استاذى محمد حسن ولإثراء الموضوع -تفضل السماح1.xlsx

وعليكم السلام ,يمكنك هذا بالدالة المعرفة payout Function payout(Value) Select Case Value Case 1 To 5 payout = "متبقى أقل من 5 أيام" Case 6 To 10 payout = "متبقى أقل من 10 أيام" Case 11 To 20 payout = "متبقى أقل من 20 يوم" Case 21 To 30 payout = "متبقى أقل من 30 يوم" Case 31 To 60 payout = "متبقى أقل من شهرين" Case 61 To 90 payout = "متبقى أقل من 3 شهور" Case 91 To 120 payout = "متبقى أقل من 4 شهور" Case 121 To 150 payout = "متبقى أقل من 5 شهور" Case 151 To 180 payout = "متبقى أقل من 6 شهور" Case 181 To 210 payout = "متبقى أقل من 7 شهور" Case 211 To 240 payout = "متبقى أقل من 8 شهور" Case 241 To 270 payout = "متبقى أقل من 9 شهور" Case 271 To 300 payout = "متبقى أقل من 10 شهور" Case 301 To 330 payout = "متبقى أقل من 11 شهر" Case 331 To 360 payout = "متبقى أقل من عام" Case Is >= 361 payout = "صلاحية أكثر من عام" Case Is < 1 payout = "إنتهت الصلاحية" End Select End Function فعليك بوضع هذه المعادلة بالخلية M13 مع السحب للأسفل =payout(L13) اصناف.xlsm

وعليكم السلام-لا يمكن عمل أكثر من ذلك 1برنامج.xlsm

بعد اذن اخي الرائد هذا الماكرو Option Explicit Sub Join_data() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim i%, Dic As Object, k, my_key Set Dic = CreateObject("Scripting.Dictionary") Cells(3, "H").CurrentRegion.Clear i = 3 Do Until Cells(i, "E") = vbNullString k = Cells(i, "F") If Not Dic.Exists(Cells(i, "E").Value) Then Dic(Cells(i, "E").Value) = k Else Dic(Cells(i, "E").Value) = Dic(Cells(i, "E").Value) & "," & k End If i = i + 1 Loop Cells(3, "H").Resize(Dic.Count) = Application.Transpose(Dic.keys) i = 3 For Each my_key In Dic.keys Cells(i, "I") = Dic(my_key) & "." i = i + 1 Next my_key Set Dic = Nothing With Cells(3, "H").CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With End Sub الملف للمعاينة مرفق talabia_SL.xlsm

وعليكم السلام-تم تعديل الأكواد لتصبح هكذا Private Sub CommandButton1_Click() Dim x As Integer x = 0 Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" End Sub Private Sub TextBox3_Change() TextBox4.Text = ((Val(Me.TextBox1.Value) / 100) * Val(Me.TextBox2.Value) * 1000) * Val(Me.TextBox3.Value) End Sub ttttt.xlsm

ومشاركة مع اخي واستاذي صالح غير في كود الاستيراد الموجود في النموذج الموجود في الصورة واستبدل كود استيرا بيانات المعلمين بالكود التالي Dim ImportFileName As String ImportFileName = Me.txtPath CurrentDb.Execute ("Delete * From Teacher") CurrentDb.Execute ("Delete * From Temp4") DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Temp4", ImportFileName, False DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO Teacher ( Teacher, Email ) " & _ " SELECT Temp4.f20, Temp4.f7 " & _ " FROM Temp4 " & _ " WHERE (((Temp4.f20)<>""الإسم""))" DoCmd.SetWarnings True MsgBox "تم استيراد أسماء المعلمين بنجاح" End Sub

عندك مجموعة حلول منها : الحل الأول : تعمل استعلام حذف للجدول وتحدد معييار لحقل Teacher = "الإسم" وهذا تضعه في جملة الاستعلام DELETE Teacher.Teacher FROM Teacher WHERE (((Teacher.Teacher)="الإسم")); تفضل بعطيك الحل الثاني إن شاء الله تعالى الحل الثاني : بالكود تفضل : Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = db.OpenRecordset("Teacher") rst.MoveFirst rst.Delete rst.Close MsgBox "تم الغاء السجل الأول من الجدول", vbOKOnly

وايضا ممكن ترك الجدول بدون اي تعديلات وتعديل بسيط على الكود Dim strSQL As String, X As Integer X = MsgBox("المعلم غير موجود .. هل ترغب في إضافته؟", vbYesNo + vbDefaultButton1) If X = vbYes Then strSQL = "Insert Into Teacher (Teacher,Email) values ('" & NewData & "','الايميل مطلوب')" CurrentDb.Execute strSQL Response = acDataErrAdded Else Response = acDataErrContinue End If او اي عبارة تبين ان هذا المعلم لم يتم تسجيل ايميله

شكرا لك أخي @kha9009lid ولك أحلى 🌹

حل رائع ومتنوع

Nouveau Microsoft Access قاعدة بيانات.accdb

@أحمد الفلاحجى @ابوآمنة @kha9009lid تفاعلكم في الردود يخليني ادور مشكلة في احد البرامج واطرحها هنا علشان تثرونا بما لديكم .. 😉😉😉

انت الاروع اخي صالح بارك الله فيك ولك

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

من باب تعدد الحلول في طريقة بدون الحاجة الى تغيير قيمة الحقل من مطلوب الى غير مطلوب عن طريق وضع القيمة الافتراضية للحقل الايميل =""

الحمد لله أنه قال: تفاحة ما قال عروسه لأنا مراقبين و من الخائفيين 🤣 يا ساتر 😁

ههههههههه الحمد لله اخى صالح @ابوآمنة اخدت تفاحه مش عروسه 😀 بالتوفيق اخى فايز

اتفضل اليك التعديل DoCmd.OutputTo acOutputReport, "احتياج المدرسة من المواد", "PDFFormat(*.pdf)", CurrentProject.Path & "\" & "احتياج المدرسة من المواد" & Format(Now(), "mmmyyyy") & ".pdf" , true

وعليكم السلام-فقط عليك بتعديل تنسيق الخلايا وجعلها 0 فتفضل الملف يمكنك التعديل كما تشاء قومى1.xlsx

أبسط طريقة لذلك هو تغيير خاصية الفورم RightToLeft وجعلها True بدلا من False كما بالصورة

بارك الله فيك استاذ جعفر وزادك الله من فضله

وعليكم السلام-الطلب ليس بسيط كما تدعى وان كان بسيطاً لقمت انت بعمله بمفردك وعلى الرغم ان هذا يعتبر مخالفة لقوانين وتعليمات المنتدى من رفع ملف مشروح -فتفضل هذا الملف سيفيدك كثيرا اداره المخازن.xlsm

طبعا يمكن عمل هذا من خلال هذه المعادلة =VLOOKUP($A2,$M$7:$O$16,MATCH(B$1,$M$6:$O$6,0),0) معادلة vlookup1.xls

السلام عليكم ورحمة الله وبركاته نسأل الله لكم التوفيق والسداد ،،، واجهة مشكلة عندما قمت بتحويل جداول قاعدة البيانات إلى SQL SERVER لتكبير القاعدة . المشكلة هي : اختفى حقل القيم المتعدده من مربع التحرير والسرد حيث ظهرت لي القيم أحادية. سؤالي هل يمكن إضافة القيم المتعددة من خيارات وخصائص SQL SERVER أو يمكن ذلك برمجياً بإنشاء نموذج مع القيم و مربع نعم/ لا بجواره ، ثم إدراج القيم في مربع النص بهذه الصورة تصبح ( محمد _ صالح _ علي ) وهذا عندي الخيار الأخير . آملاً أن أجد الحل لديكم ؟

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

لا يمكن اضافة اسم المعلم وتظهر هذه الرسالة في الصورة المرفقة علما أن إضافة الصنف تمام ولا مشكلة في الاضافة Library.rar

أخي بلال أذا كنت لا تحتاج الاكواد فاستخدم طريقة جعل مصدر البيانات استعلام أسرع لك ..... وان كنت مصرا على الأكواد فانظر المثال التالي....... ‏‏Nouveau Microsoft Access قاعدة بيانات - kan.accdb

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

تفضل EXTRA_FOUND (2).xlsm

وعليكم السلام اخي الفاضل 🙂 واهلا وسهلا بك في المنتدى 🙂 الخطأ عندك في السطر الاول ، حيث انه لما تنقر على كائن صح/خطأ ، فعلامة الصح قيمتها -1 ، وعلامة بدون صح قيمتها 0 ، فعليه يصبح الكود : If Me.dd = -1 Then ولكن ، ايش رأيك في هذ التنسيق ، بحيث بإستعمال TAB الكيبورد ننسق الكود ، فتصبح قراءة الكود سهله ، ونعرف كل مجموعة وين بدايتها ووين نهايتها : If Me.dd = -1 Then Dim t t = MsgBox("?? ??E ?E??I ?? ?UEE? ??? ?C?E C????C? ?? C??CE??E?", vbYesNo, "??? C????C? ?? C??CE??E") If t = vbYes Then DoCmd.SetWarnings False DoCmd.OpenQuery "C?E??C? ??? ?CE??E" Me.dd = 0 DoCmd.SetWarnings True ElseIf t = vbNo Then MsgBox "E? C?E?C?? ?? C????" End If ElseIf Me.dd = 0 Then Dim r r = MsgBox("?? ??E ?E??I ?? ?UEE? ??C?E C???? ???CE??E?", vbYesNo, "??U C????") If r = vbYes Then DoCmd.SetWarnings False DoCmd.OpenQuery "Q1" DoCmd.OpenQuery "Q2" Me.dd = 1 DoCmd.SetWarnings True ElseIf r = vbNo Then MsgBox "E? C?E?C?? ?? C???U" DoCmd.CancelEvent End If End If جعفر

بإذن الله أوافيك بالنتيجة شكر الله لك . ولك أحلى تفاحة 🍎

احسن الله اليك اخى فايز جزاه الله خيرا اخى واستاذى شيفان true = نعم = -1 false = لا = 0

غير true الى false

وعليكم السلام ورحمة الله وبركاته إليك الحل أخي الكريم حسب فهمي للملف المرفق: اختر أحد الحلين: =IF(A2>300;B2*750;"") أو: =IF(A2>300;(A2-300)*750;"") السماح.xlsx تقبل تحياتي العطرة

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

استاذ @jo_2010 بعد اختيار الصورة وكتابة التسمية غير ترتيب التسمية التوضيحية الى يمين او يسار او عام او اسفل او اعلى حسب رغبتك

انظ الصورة ادا كان البارتشن :C كما في الصورة فيمكن ان يعمل المشكلةدي حدثت معي ذات مرة وقمت بنقل بعض محتويات من :C الى:D وفتح البرنامج عادي

السؤال مبهم بعض الشيء 1- هل تريد ما موجود في العامود الاول وليس في الثاني؟؟ 2-هل تريد ما موجود في العامود الثاني وليس في الاول؟؟ 3-هل تريد المشترك بين العامودين؟؟ تم استخراج الفيم بواسطة المعادلات في الأعمدة من I الى K (الاعمدة مخفية لحسن الرؤية) لكن ليست مرتبة أبجدياً على كل خال جرب هذا الماكرو يقوم بترتيب النتائج ابجدياً في الاعمدة من M الى O Option Explicit Sub Exract_Common_Values() Rem This Macro Extract The common Of two Columns by Order Rem Created By Salim Hasbaya on 8/4/2020 If ActiveSheet.Name <> "Salim" Then GoTo Leave_Me_Please Application.ScreenUpdating = False Dim st, I% If Range("M1").CurrentRegion.Rows.Count > 1 Then _ Range("M1").CurrentRegion.Offset(1).Clear st = "SUM(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,1,0))" st = Evaluate(st) For I = 2 To st + 1 Range("M" & I).FormulaArray = _ "=INDEX(E$2:E$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Range("N" & I).FormulaArray = _ "=INDEX(F$2:F$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Range("O" & I).FormulaArray = _ "=INDEX(G$2:G$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Next With Range("m1").CurrentRegion .Value = .Value .Sort KEY1:=.Cells(1, 1), Header:=1 If .Rows.Count > 1 Then With .Offset(1).Resize(.Rows.Count - 1) .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 With .Font .Size = 14: .Bold = True End With .Columns.AutoFit End With End If End With Leave_Me_Please: Application.ScreenUpdating = True End Sub الملف مرفق EXTRA_FOUND.xlsm

بعد أذنك أخي الاستاذ @احمد الفلاحجي في نفس مثال أخي الاستاذ @kanory ضع هذا الكود بدلا من الكود الموجود ....... Dim X, d As String Dim strDB As String X = DLookup("[name1]", "[Dchoose]", "[Name2] ='" & name1.Column(2) & "'") If IsNull(Me.name1) Then MsgBox "ÚÐÑÇ ÇÎí ÇáßÑíã ... áã ÊÞã ÈÅÎÊíÇÑ ãÓÇÑ ÇáãáÝ", vbCritical, "ÇÏÎá ãÓÇÑ ÇáãáÝ" DoCmd.CancelEvent Else strDB = "D:\Saas\" & X & ".mdb" Set appAccess = CreateObject("Access.Application") appAccess.OpenCurrentDatabase strDB appAccess.Visible = True End If

مازالت المشكلة لم تحل شكرا استاذ محمد .

اما انا فرأسي يابس ولازلت اريد : 🙂 جعفر

لنفرض ان الرقم موجود في الخلية A1 جرب احدى هاتين المعادلتين (حسب اعدادات الجهاز عندك) =SUBSTITUTE(A1,"-","") Or =SUBSTITUTE(A1;"-";"")

وعليكم السلام-طالما انك لم تقم برفع ملف على الرغم ان هذا يعتبر مخالف لقوانين وتعليمات المنتدى ... فلما لا تقوم بإستخدام خاصية البحث بالمنتدى شيت حساب ضريبة كسب العمل وفقا للتعديل المتوقع يوليو2020

بعد اذن الأستاذ الرائد ولإثراء الموضوع تفضل Camtend(1).xlsm

الف رحمة على والديك استاذ @kha9009lid

احبائي اعضاء المنتدى اوفيسنا السلام عليكم ورحمة الله وبركاته في هذه الاونة الاخيرة اشوف ان كثير من احبائنا بيسئلون عن ضغط و اصلاح و نسخ الاحتياطية لذلك قمت بدمج موضوعين واحد للسيد @أبو إبراهيم الغامدي والسيد @أ / محمد صالح وتم اضافة ملح و و بهارات شوية واهديكم ....... الى الموضوع هناك نموذجين بداخل القاعدة واحد اسمه Frm1 والاخر Form1 وفي نموذج Form1 هناك زرين الاول كتبت عليه ( قم بعمل كومباكت و نسخة احتياطية عند الاغلاق ) اي اذا ضغطت علي و في النهاية قمت باغلاق القاعدة اولا سيعمل نسخة احتياطية و بعدين سيعمل كومباكت اي ضغط و اصلاح القاعدة -------- اما الزر الثاني انا كتبت عليه ( الغي عمل كومباكت و نسخة احتياطية عند الاغلاق ) اي اذا ضغطت على الزر الاول وبعدين غيرت رأيك بعمل نسخة احتياطية او عمل كومباكت اي ضغط واصلاح القاعدة تقدر ان تضغط اليه واذا اغلقت القاعدة ما بيعمل كمباكت و نسخة الاحتياطية واستخدمنا هذه الاكواد في وحدة نمطية Option Compare Database Dim F As New Form_Frm1 Public Function Startup() On Error Resume Next F.OnClose = "=BackUpMyDb()" & "=CopactMyDb()" End Function Public Function CnacelStartup() On Error Resume Next F.OnClose = "" End Function 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 واليكم القاعدة compactInClose.accdb

انا لا اعرف هل هذه المشاركتي مخالفة للقوانين ام لا اتفضل خذت هذا من برامجي اللي اعمل عليه الان BackUp.rar

هناك عديد مواضيع على ذلك وشوف هنا روبط بعضهم https://www.officena.net/ib/topic/70668-النسخ-الإحتياطي-التلقائي-لقاعدة-بيانات-واحدة-أو-أكثر-من-قاعدة-دفعة-واحده-يوميا-دون-تدخل-من-المستخدم/