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

المفروض أن الكود التالي يشتغل معك Sub SortStudents() Dim WS As Worksheet Dim lastRow As Long Dim OnRng As Range Set WS = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Application.ScreenUpdating = True Exit Sub End If Set OnRng = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear .SortFields.Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .SortFields.Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending .SetRange OnRng .Header = xlYes .Apply End With Application.ScreenUpdating = True End Sub ترتيب الاوائل v3.xlsb

غريب الكود يشتغل معي بشكل جيد اليك حل اخر لاختيار ما يناسبك Option Explicit Sub SortArray() Dim a() As Variant, i As Long, j As Long, col As Long Dim temp As Variant, lastRow As Long, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row Set OnRng = WS.Range("A1:E" & lastRow) a = OnRng.Value For i = 2 To UBound(a, 1) - 1 For j = i + 1 To UBound(a, 1) If a(i, 3) < a(j, 3) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 3) = a(j, 3) Then If a(i, 4) > a(j, 4) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 4) = a(j, 4) Then If a(i, 5) > a(j, 5) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col End If End If End If Next j Next i OnRng.Value = a End Sub ترتيب الاوائل v2.xlsb

Sub StringSort() Dim WS As Worksheet Dim lastRow As Long Dim sortRange As Range ' اسم ورقة العمل (يمكن تغييره) Const SHEET_NAME As String = "Sheet1" Application.ScreenUpdating = False ' التحقق من وجود ورقة العمل On Error Resume Next Set WS = ThisWorkbook.Sheets(SHEET_NAME) On Error GoTo 0 If WS Is Nothing Then MsgBox "ورقة العمل '" & SHEET_NAME & "' غير موجودة.", vbExclamation GoTo Cleanup End If ' العثور على الصف الأخير في العمود A lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row ' التحقق من وجود بيانات If lastRow < 2 Then MsgBox "لا توجد بيانات للفرز.", vbExclamation GoTo Cleanup End If ' تحديد نطاق الفرز Set sortRange = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear With .SortFields .Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending .Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending End With .SetRange sortRange .Header = xlYes .Apply End With Cleanup: Application.ScreenUpdating = True End Sub

😂 لم تغب عن بالي ...فعلتها لكنها لم تضبط معي

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

🔆 فكرة لامعة وجميلة فعلاً ، وتخيل انها غابت عن بال من مر من هنا وأولهم العبد الفقير الى الله

بدون الحاجة لأي تدخل برمجي أعتقد أنه بإمكانك إعادة تنسيق وتظبيط تنسيق التقرير وتضغير الحقول والخطوط لتلائم حجم ال A4 مباشرة 🙂 وهذه تجربتي : base_A.accdb

طيب ما رأيك بفكرة لم اقم بتأكيد نجاحها ، ولكنها قد تكون بداية الوصول الى حل ،، استخدم الكود التالي في زر ، وشاهد النتيجة على سبيل المثال بحفظ الملف بصيغة PDF ؟؟؟؟ Private Sub Command483_Click() Dim strReport As String Dim strFilePath As String Dim strDBPath As String Dim xlApp As Object Dim xlBook As Object Dim xlSheet As Object strReport = "rapt" strDBPath = CurrentProject.Path strFilePath = strDBPath & "\rapt_report.xls" DoCmd.OutputTo acOutputReport, strReport, acFormatXLS, strFilePath, False Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open(strFilePath) Set xlSheet = xlBook.Sheets(1) xlSheet.PageSetup.Orientation = 2 xlSheet.PageSetup.Zoom = False xlSheet.PageSetup.FitToPagesWide = 1 xlSheet.PageSetup.FitToPagesTall = False xlSheet.PageSetup.ScaleWithDocHeaderFooter = True xlSheet.PageSetup.PrintQuality = 600 xlBook.PrintOut xlBook.Close False xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing End Sub rapt_report.pdf

أحيانا ما يجعل الأمر أشبه بالمستحيل هو التمسك بفكرة وعدم التخلي عنها أو البحث عن طريقة أخرى تؤدي الى حل ,, مقصدي هو قد تكون مشكلتك في التقرير نفسه وليس في فكرة تنقيذ مطلبك !!! حاول البحث عن آلية لتصميم التقرير من جديد بفكرة مختلفة تساعدك في تحقيق طلبك ، فعد الحقول كبير جداً وانت تحاول ضغطها في ورقة A4

شكرا استاذ على التكملة

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

: تحديث *على السريع * 1- تفعيل التركيز النموذج عتد فتح بتغير اللون الاطار مع تغير الغيرالنموذج نشط 2- تصحيح الكود 😇 Update_Show_Gif_Move_Control.rar

وعليكم السلام -يمكنك استخدام هذه المعادلة لطلبك =IF(ROWS($G$12:G12)>DAY(EOMONTH(DATE($O$3,$P$4,1),0)),"",DATE($O$3,$P$41,ROWS($G$12:G12))) كشف الحضور1.xlsm

اعد فقط ضبط الجدول حسب الاول لقد تم اضافة لك زر الطباعة بالتوفيق شهادة02.xlsm