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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي لطباعة الكل او تحديد بيانات النجاح المرغوب طباعتها او حفظها بصيغة PDF بإسم الطالب في مجلد في نفس مسار الملف الرئيسي بادخال رقم البداية ورقم النهاية في مربع الاختيار Private Sub CommandButton1_Click() Dim PagFirst As Long, PagEnd As Long, i As Long Dim FolderName As String, MsgChoose As VbMsgBoxResult Dim filePath As String, wbPath As String, fileStart As String Dim fileEnd As String, fileName As String Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("بيان نجاح") Application.ScreenUpdating = False wbPath = ThisWorkbook.Path FolderName = "PDF_بيان النجــاح" filePath = wbPath & "\" & FolderName & "\" If Dir(filePath, vbDirectory) = "" Then On Error Resume Next MkDir filePath On Error GoTo 0 End If fileStart = InputBox("من أي بيان تريد البدء؟", "إدخال رقم البداية") fileEnd = InputBox("إلى أي بيان تريد الانتهاء؟", "إدخال رقم النهاية") If Not IsNumeric(fileStart) Or Not IsNumeric(fileEnd) Or Len(fileStart) = 0 Or Len(fileEnd) = 0 Then MsgBox "الرجاء إدخال أرقام بيانات النجاح صالحة", vbExclamation, "خطأ" Application.ScreenUpdating = True Exit Sub End If PagFirst = CLng(fileStart) PagEnd = CLng(fileEnd) If PagEnd > WS.Range("d1").Value Then MsgBox "رقم النهاية يتجاوز عدد الطلاب", vbExclamation, "تحذير" Application.ScreenUpdating = True Exit Sub End If If PagFirst > PagEnd Then MsgBox "رقم البداية يجب أن يكون أصغر من أو يساوي رقم النهاية", vbExclamation, "خطأ" Application.ScreenUpdating = True Exit Sub End If MsgChoose = MsgBox("لطباعة بيانات النجاح إظغط على نعم" & vbCrLf & vbCrLf & _ "لحفظ الملفات بصيغة بي دي إف إظغط لا" & vbCrLf & vbCrLf & _ "للخروج إظغط على إلغاء", _ vbYesNoCancel + vbQuestion, "إختر العملية") Select Case MsgChoose Case vbYes For i = PagFirst To PagEnd WS.Range("G1").Value = i WS.PrintOut Next i MsgBox "تم طباعة بيانات النجاح من " & PagFirst & " إلى " & PagEnd, vbInformation Case vbNo For i = PagFirst To PagEnd WS.Range("G1").Value = i fileName = Trim(WS.Range("D13").Value) If fileName = "" Then fileName = "بيان_" & Format(i, "000") End If filePath = wbPath & "\" & FolderName & "\" & fileName & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath Next i MsgBox "تم حفظ بيانات النجاح من " & PagFirst & " إلى " & PagEnd, vbInformation Case vbCancel MsgBox "تم إلغاء تنفيذ الكود", vbInformation End Select Application.ScreenUpdating = True End Sub بيان نجاح و للكشف درجات.xlsb

تم تعديل الكود توزيع المتوسط.xls

وعليكم السلام ورحمة الله وبركاته Sub UpdateDefaultValueAndRecords() Dim dbs As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim strTableName As String Dim strFieldName As String Dim strNewDefaultValue As String strTableName = "YourTbl" strFieldName = "FieldName" strNewDefaultValue = "60" Set dbs = OpenDatabase("C:\Path\To\Your\Backend\Database.accdb") Set tdf = dbs.TableDefs(strTableName) Set fld = tdf.Fields(strFieldName) fld.DefaultValue = strNewDefaultValue dbs.Execute "UPDATE [" & strTableName & "] SET [" & strFieldName & "] = " & strNewDefaultValue & " WHERE [" & strFieldName & "] = 70", dbFailOnError dbs.Close Set fld = Nothing Set tdf = Nothing Set dbs = Nothing MsgBox "تم تحديث القيمة الافتراضية وتحديث السجلات الحالية بنجاح!" End Sub

سهلة بإذن الله حدد العمود المراد تبويب “البيانات” (Data). اختر “إزالة التكرارات” (Remove Duplicates). بالتوفيق

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

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

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

وعليكم السلام ورحمة الله وبركاته بواسطة النقر المزدوج على اسم الموظف ثم كتابة المرحلة المنقول اليها يتم نقل الموظف اما نقل مجموعة موظفين ربما يقوم خبراء المنتدى بايجاد حل للموضوع Sub نقل_الموظف_بالنقر_المزدوج(employeeName As String, fromRank As String, toRank As String) Dim wsFrom As Worksheet Dim wsTo As Worksheet Dim found As Range Dim lastRow As Long On Error Resume Next Set wsFrom = ThisWorkbook.Sheets("المرتبة " & fromRank) Set wsTo = ThisWorkbook.Sheets("المرتبة " & toRank) On Error GoTo 0 If wsFrom Is Nothing Or wsTo Is Nothing Then MsgBox "المرتبة غير صحيحة.", vbExclamation Exit Sub End If Set found = wsFrom.Columns(3).Find(What:=employeeName, LookIn:=xlValues, LookAt:=xlWhole) If Not found Is Nothing Then lastRow = wsTo.Cells(wsTo.Rows.Count, 3).End(xlUp).Row + 1 wsTo.Rows(lastRow).Value = wsFrom.Rows(found.Row).Value wsTo.Cells(lastRow, 4).Value = toRank wsFrom.Rows(found.Row).Delete MsgBox "تم نقل الموظف بنجاح.", vbInformation Else MsgBox "لم يتم العثور على الموظف.", vbExclamation End If End Sub ثم في كل صفحة اكتب الكود التالي Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim employeeName As String Dim fromRank As String Dim toRank As String If Target.Column = 3 And Target.Row >= 2 Then employeeName = Target.Value fromRank = Replace(Me.Name, "المرتبة ", "") toRank = InputBox("أدخل المرتبة المنقول إليها للموظف " & employeeName & ":") If toRank = "" Then Exit Sub Call نقل_الموظف_بالنقر_المزدوج(employeeName, fromRank, toRank) Cancel = True End If End Sub ترحيل موظف1.xlsb

تمت معالجة هذا الأمر كثيرا قبل ذلك ربما تفيدك هذه الروابط Showing results for 'طباعة الكل pdf' in content posted in منتدى الاكسيل Excel . - أوفيسنا (officena.net) بالتوفيق

وعليكم السلام ورحمة الله وبركاته =Nz([Forms]![SubForm1]![TextBox1], 0) + Nz([Forms]![SubForm2]![TextBox2], 0) + Nz([Forms]![SubForm3]![TextBox3], 0) + Nz([Forms]![SubForm4]![TextBox4], 0)

تفضل حسب طلبك تعديل على المرفق كما وضحته لك اعلاه وزيادة تسجيل الدورات التدريبية2.rar

تفضل اخي Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim F As Worksheet Dim WS As Worksheet Dim rowNumber As Long Dim cellValue As String '********التحقق من أن النقر كان على الخلية K2 فقط If Not Intersect(Target, Me.Range("K2")) Is Nothing Then Cancel = True Set F = ThisWorkbook.Sheets("إدخال") Set WS = ThisWorkbook.Sheets("نموذج") ' الحصول على قيمة الخلية K2 cellValue = F.Range("K2").Value '*********التحقق مما إذا كانت كلمة "تقديم" موجودة في الخلية K2*** If InStr(cellValue, "تقديم") > 0 Then ' تحديد الصف الأول rowNumber = 2 '******* نسخ البيانات من الصف الأول إلى ورقة "نموذج************ WS.Range("B2").Value = F.Cells(rowNumber, "B").Value WS.Range("H2").Value = F.Cells(rowNumber, "C").Value WS.Range("B7").Value = F.Cells(rowNumber, "D").Value WS.Range("B3").Value = F.Cells(rowNumber, "E").Value WS.Range("G3").Value = F.Cells(rowNumber, "F").Value WS.Range("B4").Value = F.Cells(rowNumber, "I").Value WS.Range("B8").Value = F.Cells(rowNumber, "J").Value WS.Range("E7").Value = F.Cells(rowNumber, "G").Value WS.Range("H7").Value = F.Cells(rowNumber, "H").Value Else MsgBox "كلمة 'تقديم' غير موجودة في الخلية K2.", vbExclamation End If End If End Sub طلب اجازة v1.xlsb