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

Try this code (adjust well the template worksheet) Sub Test() Dim wsTemplate As Worksheet, nameList As Range, newName As String, i As Long Application.ScreenUpdating = False Set wsTemplate = ThisWorkbook.Worksheets("Vehicle") Set nameList = Sheets("Data").Range("A2:A11") For i = 1 To nameList.Rows.Count newName = "T_" & nameList.Cells(i, 1).Value If Evaluate("ISREF('" & newName & "'!A1)") Then Application.DisplayAlerts = False ThisWorkbook.Worksheets(newName).Delete Application.DisplayAlerts = True End If wsTemplate.Copy After:=Worksheets(ThisWorkbook.Worksheets.Count) With ActiveSheet .Name = newName .Range("B2").Value = Mid(newName, 3, Len(newName)) End With Next i Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

السلام عليكم ورحمة الله تعالى وبركاته ملاحظة :بعد ادن الاخوة الكرام بعد معاينة الكود الموجود في اليوزرفورم السائل ربما يقصد انشاء اوراق عمل جديدة طبق الاصل للورقة المخفية (sample) بشرط الاسماء الموجودة في عمود H شيت ( Vehicle ) واعادة تسميتها بنفس القيمة

وعليكم السلام ورحمة الله وبركاته الملف المرفق لعل به طلبكم. ترتيب الطلاب.xls

تفضل اخي ربما هدا ما تقصد Sub Test() Dim ws As Worksheet Dim rng As Range Dim cell As Range On Error GoTo Errorhandling Set ST = Sheet1 Set st2 = Sheet2 lr = ST.Range("H" & Rows.Count).End(xlUp).Row Sheet1.Range("B2:B" & lr).ClearContents st2.Visible = True Set rng = Range("H2:H" & lr) Application.DisplayAlerts = False Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ws.Delete End If Next For Each cell In rng If cell <> "" Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = cell Range("i19").Value = ActiveSheet.Name End If Next cell Errorhandling: Sheet1.Activate Sheet1.Range("b2").Select For Each ws In ActiveWorkbook.Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name ActiveCell.Offset(1, 0).Select Application.DisplayAlerts = True Application.ScreenUpdating = True End If Next ws st2.Visible = False End Sub

السلام عليكم ورحمة الله اذا كان فهمي صحيح هذا طلبك المرفق Personal1 (1).xlsm y = [I1].Value ''I1'هنا مسؤل عن اخذ الاسم من خلية

السلام عليكم اخي ابو مهند قد تلاحظ تأخر الرد على طلبك اولا احييك على حسن تصميم الجداول واتباع القواعد في كتابة اسماء الكائنات والعناصر ثانيا نصيحة من محب : اعد تصميم برنامجك ، واستعن باخوتك هنا بعض التوجيه حول التصميم : 1- جدول الحضور يجب ان يشتمل على التالي فقط واكرر فقط - معرف الموظف - حقل تاريخ ووقت جنرال / والبعض يفضل ان يكونا حقلين منفصلين واحد للتاريخ والآخر للوقت - حقل رقمي لنوع الشفت ( صباحي /مسائي / ليلي ) وهكذا ... 2- جدول خاص باوقات الدوام ( الشفت) : - حقل لرقم تعريف الشفت - حقل الوقت / من - حقل الوقت / الى ............................. احب لأخيك ما تحب لنفسك

ابشر .. تم ترتيب الطلاب.xls

السلام عليكم و رحمة الله ترتيب الطلاب من الاول حتى العاشر على اساس الدرجات فى العمود T Sub ReRank() Dim ws As Worksheet, Arr() Dim LR As Long, y As Integer, TP() Dim j As Long, p As Long, m As Long, Trb As String Dim i As Long, x As Double, k As Double Set ws = Sheets("ورقة البيانات") LR = ws.Range("C" & Rows.Count).End(3).Row Range("U8:U" & LR).Value = "" ReDim Arr(1 To LR, 1 To 1) j = 8 Do While j <= LR y = WorksheetFunction.CountIf(ws.Range(ws.Cells(8, "T"), _ ws.Cells(j, "T")), ws.Cells(j, "T")) If y = 1 Then i = i + 1 Arr(i, 1) = ws.Cells(j, "T") End If j = j + 1 Loop x = WorksheetFunction.Large(Arr, 10) ReDim TP(1 To i, 1 To 1) For r = 1 To i If Arr(r, 1) >= x Then p = p + 1 TP(p, 1) = Arr(r, 1) End If Next m = 8 Do While m <= LR For n = 1 To 10 k = WorksheetFunction.Large(TP, n) If ws.Cells(m, "T") = k Then Trb = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") If WorksheetFunction.CountIf(ws.Range("T8:T" & m), _ ws.Range("T" & m)) > 1 Then Trb = Trb & " " & "مكرر" ws.Cells(m, "U") = Trb Else Trb = Trb ws.Cells(m, "U") = Trb End If End If Next m = m + 1 Loop End Sub

نسخة تجريبية للعميل _ تشفير لوقت محدد السلام عليكم اخوتي الكرام : احببت ان افرد العمل بعنوان مستقل ليكون قريبا للباحث وكنت وعدت بطرح مثالي المفتوح في موضوع سابق هنا وعندما راجعت مثالي بعد انقضاء الفترة تبين لي وجود ثغرات ، فقمت باصلاح الخلل وتجربة المثال اكثر من مرة للتأكد من عمل الأكواد على اكمل وجه . الفكرة : تحديد تاريخين من قبل المبرمج يتم تشفيرهما ، ولن يعمل البرنامج الا بين هذين التاريخين فقط بهذه الطريقة اغلقنا الطريق على من يحاول تغيير تاريخ الجهاز بعد انقضاء فترة التجربة والاتفاق على شراء البرنامج يتم ارسال نسخة دائمة الى العميل . يجب تقسيم قاعدة البيانات الى واجهات وجداول من اجل الحفاظ على بيانات العميل التي تم ادخالها خلال التجربة . ختاما ؛ اليكم الاكواد الخاصة مع المرفق دعواتكم ،،، Function EncryptDecrypt(strIn As String, strPass As String) As String Dim intLen As Integer Dim intCounter As Integer Dim varTmp As Variant Dim strTmp As String intLen = Len(strPass) strTmp = strIn For intCounter = 1 To Len(strIn) varTmp = Asc(Mid$(strPass, (intCounter Mod intLen) - intLen * ((intCounter Mod intLen) = 0), 1)) Mid$(strTmp, intCounter, 1) = Chr$(Asc(Mid$(strIn, intCounter, 1)) Xor varTmp) Next EncryptDecrypt = strTmp End Function Private Sub cmd1_Click() 'لإدراج التاريخ في الحقلين ثم تعديل الحقول يدويا حسب الفترة المطلوبة ' يستخدم مرة واحدة قبل التشفير Me.regEnd = Now() Me.regStart = Now() Me.Requery End Sub Private Sub cmd2_Click() ' تشفير الحقلين ولاحظ ان الزر يشفر ويفك التشفير في نفس الوقت Dim strPassword As String strPassword = "EnDecryptAccessOfficna" Me.regStart = EncryptDecrypt(Me.regStart, strPassword) Me.regEnd = EncryptDecrypt(Me.regEnd, strPassword) End Sub Private Sub Form_Current() On Error Resume Next Dim strRegStart, strRegEnd, vNowv As Date Dim strPassword As String vNowv = Now() strPassword = "EnDecryptAccessOfficna" strRegStart = EncryptDecrypt(Me.regStart, strPassword) strRegEnd = EncryptDecrypt(Me.regEnd, strPassword) 'عند العبث بالشفرة في اي من الحقلين If Not IsDate(strRegEnd) Or Not IsDate(strRegStart) Then MsgBox "تم التلاعب بالشفرة .. سيتم اغلاق البرنامج" DoCmd.Quit End If ' عند نهاية الفترة If vNowv > strRegEnd Then MsgBox "انتهت الفترة التجريبية .. تواصل مع المبرمج " DoCmd.Quit End If ' عند تغيير تاريخ الكمبيوتر لان النسخة المؤقتة ستعمل فقط بين التاريخين المرصودين If vNowv <= strRegStart Then MsgBox "تم تغيير تاريخ الجهاز .. سيتم غلق البرنامج " DoCmd.Quit End If End Sub تشفير.rar

السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb

السلام عليكم لدي جدول اسمه شراء ونموذح فرعي تظهر به اسماء الموردين اريد اظهار الرصيد في حقل الرصيد بالنموذح باعتبار حدول شراء حاولت بدالة dsum وفشلت ارجو المساعدة والتوضيخ Database4.accdb

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة البحث بشرطين بواسطة كومبوبوكس تم ارفاق كود الحل من الفاضل / أبو حنــــين و لا تنسونا من صالح الدعاء تحياتى كمبوكس بحث بشرطين.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) StartColumn = 6 ' اول عمود LastColumn = 40 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn Application.ScreenUpdating = False If Range("b20").Value = "" Then Columns("F:H").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i End Sub كود اخفاء.xlsm

آمل ان يكون هذا هو مطلوبك Public Function OrderAwael(Roundx As Double) As String Set rs = CurrentDb.OpenRecordset("SELECT COUNT(*) + 1 FROM (SELECT qryRank.Rounded FROM qryRank GROUP BY qryRank.Rounded) As temp WHERE temp.Rounded > " & Roundx, dbOpenSnapshot) OrderAwael = rs(0) rs.Close End Function Ranks.accdb

الله ينور ي استاذ @lionheart كود أكثر من رائع 🌹

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

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

هو حضرتك لو كنت رفقت ملف كان اسهل علينا وعليك..عشان افهم ايه اللي يجرى

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

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

وعليكم السلام سؤالك عام ..فالجواب سيكون عام لإنشاء استعلام إلحاق بين تاريخين في Access ، يمكنك اتباع الخطوات التالية: قم بإنشاء استعلام جديد في Design View. أضف الجدول الذي تريد إلحاق البيانات به والجدول الذي تريد الحاق البيانات منه إلى الاستعلام. ثم حدد " استعلام إلحاق " في قسم "نوع الاستعلام". حدد الحقول من الجدول التي تريد إلحاق البيانات به والحقول المقابلة من الجدول الذي تريد الحاق البيانات منه. في صف "المعايير" في حقل التاريخ الذي تريد تقييد الإلحاق به ، أدخل النطاق الزمني الذي تريد استخدامه. على سبيل المثال ، إذا كنت تريد إلحاق البيانات من 1 /1/ 2022 إلى 31 /12/ 2022 بالجدول ، يمكنك استخدام المعايير التالية: =#1/1/2022# AND <= #31/12/2022#

وعليكم السلام 1- عرف عن موديول هكذا .. Dim tempValue As TempVars 2- في حدث عند الضغط على الزر الموجود في النموذج الاول ضع السطر التالي .. TempVars!tempValue = Me.txtValue.Value txtValue هو اسم مربع النص في النموذج الاول 3- في حدث عند الفتح للنموذج الثاني ضع السطر .. Me.txtValue1 = TempVars!tempValue txtValue1 هو اسم مربع النص في النموذج الثاني

استخدم دالة المتغير المؤقت ( teampvar ) الافضل تنزل لنا القاعده عشان يخدمونك الشباب

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

وعليكم السلام ورحمه الله وبركاته راجع المرفق تم عمل المطلوب ان شاء الله بحث.xls

المواصفات والقيود لا تزيد اخى

عليكم السلام لم افهم المطلوب ترحيل رقم التسلسل ام وضع تسلسل 1-30 في كل صفحة؟؟؟

نعم اخوك وابنكم الصغير ( 39 سنه قال ايه صغير 😀 ) وطالب علم اتعلم منكم ومعكم ومن اخوانى واساتذتى جزاهم الله عنا كل خير تقبل تحيات اخوك وابنكم الصغير احمد

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

اخي طارق نادر جرب المرفق تحويل معادلة إلى كود.xlsm

والله نجحت فى تعديل على الكود ليتماشى مع ملفك ويكون شيت الورد مفتوح الترحيل من الاكسيل الى الورد.rar

تفضل Private Sub CommandButton6_Click() Select Case ComboBox1.Value Case "بحث في الاسماء" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("a2:a" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 2).Value ListBox1.List(j, 2) = Cells(C.Row, 3).Value j = j + 1 End If Next C Case "بحث في الرقم القومي" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("c2:c" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 3).Value j = j + 1 End If Next C Case "بحث في تاريخ الميلاد" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("b2:b" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 2).Value j = j + 1 End If Next C End Select End Sub 1- 2- 3- project.xlsm