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

تفضل اخي Private Sub Worksheet_Change(ByVal Target As Range) Dim WRng As Range, WRng2 As Range Dim rg As Range, rg2 As Range Dim ST1 As Integer, ST2 As Integer Set WRng = Intersect(Application.ActiveSheet.Range("B8:B1000"), Target) Set WRng2 = Intersect(Application.ActiveSheet.Range("d8:d1000"), Target) On Error Resume Next ST1 = 1 ST2 = 1 If Not WRng Is Nothing Then Application.EnableEvents = False For Each rg In WRng If Not VBA.IsEmpty(rg.Value) Then rg.Offset(0, ST1).Value = Now rg.Offset(0, ST1).NumberFormat = "dd-mm-yyyy HH:mm" Else rg.Offset(0, ST1).ClearContents End If Next Application.EnableEvents = True End If If Not WRng2 Is Nothing Then Application.EnableEvents = False For Each rg2 In WRng2 If Not VBA.IsEmpty(rg2.Value) Then rg2.Offset(0, ST2).Value = Now rg2.Offset(0, ST2).NumberFormat = "dd-mm-yyyy HH:mm" Else rg2.Offset(0, ST2).ClearContents End If Next Application.EnableEvents = True End If End Sub مسحوبات الخطوط.xlsm

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

استاذ محمد @محمد احمد لطفى ظهرت لي بهذا الشكل لكن لا اعلم ان كانت صحيحة لان الهارد عندي تقريبا 600..فكيف ظهر 640؟

الرقم الأول، من الأربعة عشر رقمًا من جهة اليسار، إذا كان رقم (2) فهو خاص بمواليد 1900 حتى 1999، وإذا كان رقم (3) فنجد أنه خاص بمواليد 2000 حتى 2099، وهكذا كلما مر قرن زاد هذا العدد واحدًا. أما الأرقام من الثاني وحتى السابع، من اليسار، فهي خاصة بتاريخ ميلاد صاحب البطاقة، مثل «05 07 83»، فنلاحظ أن 05 تعني أنه مولود في يوم 5، و07 تعني شهر يوليو، و83 أي سنة 1983، وهكذا في بقية التواريخ. والرقمان الثامن والتاسع، من اليسار أيضًا، فهما للدلالة على كود المحافظة التي ولد فيها هذا الشخص، وأكواد محافظات مصر على بطاقة الرقم القومي هي: القاهرة 01، الإسكندرية 02، بورسعيد 03، السويس 04، دمياط 11، وهكذا. وإذا كان الشخص مولودًا خارج جمهورية مصر العربية فيكون الرقم ثابتًا 88 لكل المولودين خارجها. ثم نأتي للأرقام من العاشر وحتى الثالث عشر، فهي تشير إلى تسلسل الشخص على الكمبيوتر بين المواليد في يوم ميلاده، ولا علاقة لهذا التسلسل بسجلات المولود في السجلات الورقية؛ ويجب توضيح أن الرقم الثالث عشر (13) يشير إلى نوع المولود ذكر أم أنثى، فإذا كان عددًا فرديًا (1 أو 3 أو 5 أو 7 أو 9) فصاحب البطاقة ذكر، وإذا كان زوجيًا (2 أو 4 أو 6 أو 8) فهي أنثى. أما بالنسبة للرقم الأخير فوضعته وزارة الداخلية للتحقق من صحة الرقم القومي وأن البطاقة ليست مزورة، ويختلف الرقم من بطاقة لأخرى بين الرقم 1 و9. كما أن الرقم المدون في الوجه الخلفي لبطاقة الرقم القومي أسفل النسر هو رقم المصنع الذي قام بإنتاج البطاقة، وهذا الرقم يختلف من مصنع إلى آخر، والغرض من تدوينه على البطاقة هو سرعة التوصل لأي بطاقة مزورة لتحديد موظف الأحوال المدنية الذى قام بإصدار البطاقة لبيان مسؤوليته عن إصدار بطاقة مزوّرة.

وعليكم السلام.. عملته لك حسب المخصص..اعتقد الافضل ان يكون البحث عن طريق مربع تحرير جرب ووافني بالنتيجة mus1.rar

وعليكم السلام ورحمة الله وبركاته تفضل أخي الكريم لعله يفيدك بإذن الله علماً أن QRCODE لا يعمل - حسب علمي - إلا بالاتصال بالنت. تم استخدام كود موجود في هذا الموقع وتعديل على المعادلة لتناسب الطلب. تقبل تحياتي. QRCODE.xlsm

السلام عليكم ورحمه الله وبركاته شوف الموضوع أدناه قد يفيدك ⬇️ يمكنك فعل هذا بوضع بكل سهوله لعرض كومبوبوكس مخفي في VBA، يمكنك استخدام الأمر التالي: ComboBox1.Visible = False هذا سيجعل الكومبوبوكس مخفيًا، مما يعني أنه لن يتم عرضه على الشاشة. لإظهار الكومبوبوكس، يمكنك إعادة تعيين الخاصية Visible إلى True: ComboBox1.Visible لعرض كومبوبوكس مخفي في VBA، يمكنك استخدام الأمر التالي: ComboBox1.Visible = False هذا سيجعل الكومبوبوكس مخفيًا، مما يعني أنه لن يتم عرضه على الشاشة. لإظهار الكومبوبوكس، يمكنك إعادة تعيين الخاصية Visible إلى True: ComboBox1.Visible= True

قبل لا نخرج عن الموضوع الرئيسي .. 🙂 الفكرة هي التصويت على الأفكار المتميزة بمختلف مواضيعها ثم تسليط الضوء عليها وتكريم أصحابها .. المشاريع الجماعية فكرة أخرى سننظر فيها لاحقاً .. 😄

لدي فكرة لتطوير هذا المقترح : 1- دعنا في هذا الموضوع نجمع المواضيع التي يتم ترشيحها للتصويت .. ومن ثم في موضوع جديد يتم عمل التصويت عليها 🙂 2- يتم تجميع المواضيع المتميزة خلال سنة 2022 إلى الآن مثلا .. (هل الفترة مناسبة ؟) 3 - يتم إعادة التصويت مرة أخرى في منتصف كل عام . 4- المواضيع المتميزة يتم وضعها في موضوع خاص بها يتم تثبيته لمدة محددة تكريما لأصحابها 🙂 5- يمكن اقتراح هدية معينة للفائزين 🧐 هل من أفكار إضافية ؟

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

السلام عليكم و رحمة الله اجعل المعادلة هكذا =IF(AND(COUNTIF($AH$1:$AH$7;$H8)>0;COUNTIF($AH$1:$AH$7;$J8)>0);3;IF(COUNTIF($AH$1:$AH$7;J8)>0;2;IF(COUNTIF($AH$1:$AH$7;H8)>0;1;"")))

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

1 - حبيبي الغالي انت مش يرضيك ان حاجة تعدي كدة بدون فهم خاصة ونحن في اطار دروس نتعلم منها من غزير علمكم اخي فممكن مثال اخي علي مربع السرد المتعدد 2 - هل من الممكن بنفس طريقة اخفاء الجدول يتم اخفاء كافة الاستعلامات والنماذج والتقارير والماكرو والوحدات النمطية (الاوامر البرمجية ) او المديول بحيث لا تظهر عند اظهار الملفات المخفية

وجدت لك هذا المرفق يشتمل على بعض الجداول الاساسية ، اعجبني التصميم لعلك تستفيد منه account.mdb

طيب الكود عندك...وركبه زي ماحضرتك بتشوف ☺️

بس لو اعرف انت عاوز ايه من الهارد ديسك المسكين hard disk2.rar

بالتأكيد يظهر لك هذا الخطأ لان النص فارغ... اعمله هكذا .. If Me.txtSearch.Value <> " " Then DoCmd.OpenReport "تقرير حسب المخصص", acViewPreview Else MsgBox "ادخل المخصص رجاء" Me.txtSearch.SetFocus End If

كأني رأيت المرفق من قبل تفضل تم اضافة زر للنسخ تأكد اولا من اعدادات مكان القاعدة ومكان النسخة MS_LOGO2.rar

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

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

السلام عليكم و رحمة الله استخدم المعادلة التالية =IF(COUNTIFS($AH$1:$AH$7;$H8;$AH$1:$AH$7;$J8)>0;3;IF(COUNTIF($AH$1:$AH$7;H8)>0;1;IF(COUNTIF($AH$1:$AH$7;J8)>0;2;"")))

Book1.xlsx

السلام عليكم ورحمة الله وبركاته في هذا الكود يقوم بنسخ Sheet1 وفتح ورقة جديدة على حسب المكتوب في Sheet1 في الخلية O14 والكود يقوم بنقل البيانات التي في الورقة بدون اي دوال المطلوب ان ينقل البيانات بدون دوال من العمود A10 الى Z400 وبقيت الخلايا يترك الدوال بداخلها الملف المرفق موضح المطلوب Sub CopySheet() Dim strName As String, SH As Worksheet strName = Trim(Sheet4.Range("o14").Value) For Each SH In Worksheets If SH.Name = strName Then Exit Sub Next SH Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete .Cells.Copy .Cells.PasteSpecial xlPasteValues End With Application.CutCopyMode = False Sheets("sheet1").Select Range("A1").Select End Sub نسخ الشيت.xlsm

بارك الله

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

ربما Sub CopySheet() Dim strName As String, SH As Worksheet strName = Trim(Sheet4.Range("o14").Value) For Each SH In Worksheets If SH.Name = strName Then Exit Sub Next SH Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete With .Range("A10:Z400") .Value = .Value End With End With Sheets("sheet1").Select Range("A1").Select End Sub

هكذا؟ Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6), a(i, 7), a(i, 8))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) .Item(a(i, 1)) = w End If Next For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub اذا لم يكن المطلوب أرجو أن ترفق ملف فيه النتائج المتوقعة شكراً

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

تفضل أخي الكريم استبدل باكود: Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) .Item(a(i, 1)) = w End If Next itm = .items For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(UBound(a, 2) - 4, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub

الله ييارك فيك اخي الكريم.

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

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

جرب هذه الاضافة ووافنا بالنتيجة. Private Sub Form_Load() Me.Image1.SizeMode = fmPictureSizeClip End Sub

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

طالما انت عملتها خلف الزر...اعمل مربع نص في النموذج لادخال الرقم ..ثم غير السطر في الكود الى strInvoiceID = Me.Text1

وجدت لك هذه وحدة نمطية عامة اجعلها في مديول #If VBA7 Then Private Declare PtrSafe Function GetShortPathName Lib "kernel32" _ Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long #Else Private Declare Function GetShortPathName Lib "kernel32" _ Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long #End If Public Function GetShortName(ByVal sLongFileName As String) As String Dim lRetVal As Long, sShortPathName As String, iLen As Integer 'Set up buffer area for API function call return sShortPathName = Space(255) iLen = Len(sShortPathName) 'Call the function lRetVal = GetShortPathName(sLongFileName, sShortPathName, iLen) 'Strip away unwanted characters. GetShortName = Left(sShortPathName, lRetVal) End Function ويتم مناداتها بهذا السطر Shell ("cmd /c mspaint /p " & GetShortName(CurrentProject.path & "\" & Me.picFld & ".jpg"))

اخي هيثم انت لم تقم بربط الازرة في النموذج الرئيسي بالنماذج الاخرى .... اكمل الربط ... لمساعدتك ...

اخي الحبيب الغالي السلام عليكم ورحمة الله وبركاته تم تنفيذ الخطوة 3 وهي انشاء الجدول والخطوة 4 وهي انشاء قاعدة بيانات امامية محمية بكلمة مرور فما هي الخطوة التالية بارك الله فيك اخي وما راي حضرتك في هذا الحدث الذي يخفي الجدول ويظهره دون الحاجه لغلق القاعدة وفتحها مرة اخري اليك المرفق اخي 04- craet table with hard code.rar

4- انشاء قاعدة البيانات الأمامية مأمنة بكلمة مرور Public Function DoCreatDatabaseByPassword( _ Optional strDbPath As String = "", _ Optional strNewDbName As String = "", _ Optional strPassNewDb As String = "" _ ) On Error GoTo ErrorHandler Dim wrkDefault As Workspace Dim db As DAO.Database If IsNull(strDbPath) Or strDbPath = Null Or strDbPath = vbNullString Or strDbPath = Empty Or strDbPath = "" Or Len(strDbPath) = 0 Then strDbPath = CurrentProject.Path & "\" If IsNull(strNewDbName) Or strNewDbName = Null Or strNewDbName = vbNullString Or strNewDbName = Empty Or strNewDbName = "" Or Len(strNewDbName) = 0 Then strNewDbName = "NewDB.mdb" If IsNull(strPassNewDb) Or strPassNewDb = Null Or strPassNewDb = vbNullString Or strPassNewDb = Empty Or strPassNewDb = "" Or Len(strPassNewDb) = 0 Then strPassNewDb = "00" Set wrkDefault = DBEngine.Workspaces(0) If Dir(strDbPath & strNewDbName) <> "" Then Kill strDbPath & strNewDbName Set db = wrkDefault.CreateDatabase(strDbPath & strNewDbName, dbLangGeneral & ";PWD=" & strPassNewDb) strDbPath = vbNullString strNewDbName = vbNullString strPassNewDb = vbNullString Set wrkDefault = Nothing db.Close Set db = Nothing ExitHandler: Exit Function ErrorHandler: MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description Resume ExitHandler End Function التطبيق فى القاعدة المرفقة .. يتبع ... 05- CreatDatabaseByPassword.accdb

الشكر لله الحمد لله الذى تتم بنعمته الصالحات

الحمد لله .. الفضل له .. وشكرا على ثنائك العطر

وعليكم السلام ورحمة الله تعالى وبركاته ...تفضل اخي Sub creation_onglets_MH() Dim contenu As String Dim lig As Long, MH As Long Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each ws In Worksheets If ws.Name <> "data" Then ws.Delete Next ws With Sheets("data") MH = .Range("E" & Rows.Count).End(xlUp).Row For lig = 4 To MH contenu = .Cells(lig, 5).Value If contenu = "" Then GoTo Suite If FeuilleExiste(ThisWorkbook, contenu) Then .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Else Sheets.Add ActiveSheet.Name = contenu .Rows(1).Copy Sheets(contenu).Range("A3") .Rows(lig).Copy Sheets(contenu).Range("A4") With .Range("A:E") .HorizontalAlignment = xlCenter Range("a:a").ColumnWidth = 5 Range("b:b").ColumnWidth = 28.71 Range("c:c,d:d").ColumnWidth = 10 Range("E:E").ColumnWidth = 13 Dim i For i = 4 To 100 If ws.Name <> "data" Then Rows(i).RowHeight = 33 End If Next i End With End If Suite: Next lig Sheets("data").Activate NbSheet = ActiveWorkbook.Sheets.Count Range([A3], [IV3].End(xlToLeft)).Select Set MaPlage = Selection [A1].Select For NS = 1 To NbSheet Set Destination = ActiveWorkbook.Sheets(NS).Range("A3") MaPlage.Copy Destination Next NS Sheets("data").Move Before:=Sheets(1) Application.DisplayAlerts = True Application.ScreenUpdating = True End With End Sub Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean On Error Resume Next FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing) End Function move row_MH.xlsm

شكرا لك استاذي للإشارة للموضوع استاذي الكريم احياناً نحتاج الى ان نقوم بعملية ضغط واصلاح لقاعدة البيانات الامامية بسبب اننا نضع جداول مؤقته(( هذه ايضاً يحذرنا منها استاذنا @jjafferr ))نرحل اليها بعض السجلات وبعد انتهاء المهمة نقوم بحذفها اساس المشكلة ليست بالضغط والاصلاح المشكلة في اخفاء الجداول واعادة الاتصال بها مرة اخرى بعد تغيير المسار ومع حقل محدد من نوع مربع تحرير وسرد يقبل عدة قيم جربت على اصدار 2016 أخر نسخه وأخر تحديث على نظام وندوز ثاني غير اللي انا اشتغل عليه وظهرت نفس المشكلة قمت بعمل مثال يمكنكم التجربه عليه باتباع الخطوات التالية الجداول المرتبطه بالقاعدة الامامية غير مخفية قم بالخطوات التالية لترى المشكلة بعد فك الضغط عن الملف 1- افتح قاعدة البيانات الواجهة Hide_linked_tables 2- اعد ربط الجداول بقاعدة البيانات الخلفية الان اعمل ضغط واصلاح او تحويل قاعدة البيانات الى Accde ستجد ان اعملية تتم بدون مشاكل الان قم بالخطوات التالية 1- قم باخفاء الجداول المرتبطة من خلال النموذج frm_htbl 2- اغلق قاعدة البيانات الواجهة 3- قم بتغير مسار قاعدة البيانات الخلفية 4- افتح قاعدة البيانات الواجهة وأظهر الجداول من خلال النموذج افتح أي جدول سيظهر لك رسالة ان مسار قاعدة البيانات غير موجود اعد ربط الجداول مرة أخرى ثم افتح الجدول سيعمل بدون مشاكل الان حاول القيام بعملية اضغط واصلاح او تحويل لقاعدة البيانات الى Accde ستجد ان المشكلة ظهرت من خلال الرسالة hidtbl.rar