عبدالله بشير عبدالله

وعليكم السلام ورحمة الله وبركاته
ملفك لا بحتوى على اي كود
تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات
Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb
 

لم افهم ما المقصود بالتنسيق
وان كنت تقصد  العمود الاخير M غير ظاهر في ملف PDF  فاستبدل في الكود   نطاق البيانات
Range("A1:L" & lastRow).ExportAsFixedFormat _ بهذا المدى 
Range("A1:M" & lastRow).ExportAsFixedFormat _ يعتى بدل العمود L يصبح M
عمالة نظام جديد2025_2026.xlsm

السلام عليكم
حسب فهمى لطلبك وبدون ارفاق ملف منكم اليك الكود
Sub RunMacroWithPassword() Dim password As String Dim userInput As String password = "1234" userInput = InputBox("من فضلك أدخل كلمة السر لتشغيل الماكرو:", "كلمة السر") If userInput = password Then MsgBox "كلمة السر صحيحة، سيتم الآن تشغيل الماكرو.", vbInformation Call MyProtectedMacro Else MsgBox "كلمة السر غير صحيحة. لن يتم تشغيل الماكرو.", vbCritical End If End Sub Sub MyProtectedMacro() MsgBox "تم تشغيل الماكرو بنجاح!", vbInformation ' أضف الكود الحقيقي هنا... End Sub الكود الاول   Sub RunMacroWithPassword()    وفيه المطالبة بكلمة السر وهي 1234
والكود الثاني Sub MyProtectedMacro()    وهو الذي سيتم تنفيذه بعد وضع كلمة السر
مثال
تنفيذ ماكرو مع ادخال كلمة سر.xlsb

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

السلام عليكم
حسب قهمى  لطلبك
ترتيب حسب اللون.xlsb

السلام عليكم ورحمة الله وبركاته
اليك  ما طلبت 
Sub ExportCertificatesToSinglePDF() Dim lr As Long, i As Long, pageCount As Long Dim pdfPath As String, wsMain As Worksheet, tempWS As Worksheet Dim tempSheetNames As Collection Dim sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsMain = ThisWorkbook.Sheets("معلمين") Set tempSheetNames = New Collection wsMain.Range("m2").FormulaR1C1 = "=COUNTA('جدول عام'!R6C1:R22C1)" lr = wsMain.Range("m2").Value i = 1 pageCount = 1 Do Until i > lr wsMain.Range("m2").Value = i wsMain.Copy After:=Sheets(Sheets.Count) Set tempWS = ActiveSheet tempWS.Name = "Temp_" & pageCount tempWS.PageSetup.PrintArea = "$A$1:$i$37" tempSheetNames.Add tempWS.Name i = i + 3 pageCount = pageCount + 1 Loop pdfPath = ThisWorkbook.Path & "\الشهادات.pdf" Dim wsArray() As Variant ReDim wsArray(1 To tempSheetNames.Count) For i = 1 To tempSheetNames.Count wsArray(i) = tempSheetNames(i) Next i ThisWorkbook.Sheets(wsArray).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath For i = 1 To tempSheetNames.Count Application.DisplayAlerts = False ThisWorkbook.Sheets(tempSheetNames(i)).Delete Application.DisplayAlerts = True Next i wsMain.Select wsMain.Range("m2").Value = 1 Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "تم حفظ الشهادات في ملف PDF بنجاح!", vbInformation, "تم الحفظ" End Sub تحويل الشهادات الى pdf.xlsm

السلام عليكم ورحمة الله وبركاته
اليك ما طلبت
جدول التفريغ22.xlsm
 

وعليكم السلام ورحمة الله وبركاته
الطريفة الاولى
قبل حفظ الملف ارجع الى الصفحة الرئيسية ثم حفظ
الطريقة الثاتية عن طريق كود  وسيقوم بفتح الصفحة الرئيسية  حتى لو قمت بالحفظ عند ورقة 10 مثلا
 ضع هذا الكود في محرر الاكود في ThisWorkbook
Private Sub Workbook_Open() Sheets("SHEET1").Activate End Sub طبعا غير اسم SHEET1 بالكود باسم الشيت الرئيسى لديك

وعليكم السلام ورحمة الله وبركاته
 
Private Sub Worksheet_Change(ByVal Target As Range) Dim rg As Range, cell As Range Set rg = Intersect(Target, Columns("A")) If rg Is Nothing Then Exit Sub Application.EnableEvents = False On Error GoTo CleanUp For Each cell In rg If Not IsEmpty(cell.Value) Then If Not cell.Value Like "???-###-####" Or _ IsNumeric(Left(cell.Value, 3)) Or _ Not IsNumeric(Mid(cell.Value, 5, 3)) Or _ Not IsNumeric(Mid(cell.Value, 9, 4)) Then MsgBox "الرجاء إدخال القيمة بالتنسيق الصحيح: 3 حروف-3 ارقام-4 ارقام", vbExclamation cell.ClearContents End If End If Next cell CleanUp: Application.EnableEvents = True End Sub aaa-123-4345.xlsb

السلام عليكم ورحمة الله وبركاته
بعد اذن معلمنا واستاذنا محمد هشام
جدول2.xlsm

وعليكم السلام ورحمة الله وبركانه
 اليك الملف وبه التعديل
ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 5.xlsb
وان اردت اي تعديل في الملف  فايشر
لك كل الود والاحترام

وعليكم السلام ورحمة الله وبركانه 
الكود يقوم بفرز الاسماء المكررة ويضعها في العمود C 
Sub تجميع() Dim ws As Worksheet Dim lastRow As Long, i As Long, j As Long Dim dict As Object Dim name As Variant, location As String Dim outputRow As Long Set ws = ActiveSheet Set dict = CreateObject("Scripting.Dictionary") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow name = ws.Cells(i, 1).Value location = ws.Cells(i, 2).Value If name <> "" Then If dict.Exists(name) Then dict(name) = dict(name) & " / " & location Else dict(name) = location End If End If Next i ws.Range("C1:D" & ws.Rows.Count).ClearContents outputRow = 1 For Each name In dict.Keys ws.Cells(outputRow, 3).Value = name ws.Cells(outputRow, 4).Value = dict(name) outputRow = outputRow + 1 Next name End Sub Book2.xlsb

تم التعديل 
استمارة الكترونية1.xlsm

وعليكم السلام ورحمة الله وبركاته
تم تعديل المعادلات ليكون ارتباطها بالخلية N9 فقط في صفحة استدعاء ومن ضمنها الاعمدة المخفية  D & K  مع تعديل طفيف بالكود
bac test1.xlsm
 
 
 
 

وعليكم السلام ورحمة الله وبركاته
جرب الكود  وان كان يحتاج الى تعديل اعلمنى بالامر
__نسخة aaaa_.xlsb

عذرا طلبك واضح ولكنى لم انتبه
عن طريق كود 
 
كتابة اسماء الفصول بالارقام العربية.xlsb

وعليكم السلام ورحمة الله وبركاته 
اليك الملف واستبدله  في مجلد جمع الفواتير
الكود يتعامل مع اي عدد من الملفات  امتدادها XLSM  حسب ملفاتك المرفقه ويمكن تعديلها بالكود ان نغير الامنداد
جرب الملف واعلمنى بالنتائج
جمع.xlsm
 

وعليكم السلام ورحمة الله وبركاته
جرب التعديل التالي  في الخلايا الصفراء
تعديل كود تنقيط.xlsm

وعليكم السلام ورحمة الله وبركاته
استخدم هذه المعادلة  بدون تقريب الرقم، مع عرض منزل عشرية واحدة فقط إذا وُجدت، ولا يتم عرض .0 إذا كان العدد صحيحًا
 
=IF(D2=INT(D2); D2; INT(D2*10)/10) مثال للتوضيح
العدد العشري.xlsx

وعليكم السلام ورحمة الله وبركاته
نم  النظر في  جميع الملاحظات وتم التعديل ان شاء الله
مع ملاحظة اعادة  معادلة الترقيم في شيت معاشات كنت جعلت الترقيم تلقائى لجعل الكود اسرع 
قحسب طلبك العدد سيكون اكثر من 10000  ومن اسباب ثقل الاكواد المعادلات 
وخاصة ان شيت DATA  سيكون به اكثر من 70000 معادلة اذا كان عدد الموظفين اكثر من 10000
وعلى كل حال مواصفات الجهاز الجيدة لها دور كبير في سرعة معالجة البياتان
اتمنى ان تجد طلبك في الملف ولا حرج في اي ملاحظات تراها تخدم العمل في ملفك
حفظك الله برعايته ورزقك من ثمار الجنة
ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 5.xlsb
 

السلام عليكم
ساشرح لك بمثال 
لنفرض ان الملف 1 به الكود الثالي
Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending .SetRange ws.Range("A8:AH73") .Header = xlNo .Apply End With End Sub وتريد تقل الكود الى الملف  2 حيث تريد عمود الفرز مثلا العمود  M واول صف به بيانات هو الصف 10 واخر صف به بيانات هو الصف 120 واول عمود به بيانات  B واخر عمود به بيانات هو العمود  BA
الخطوات :-
تعديل الكود ليتناسب مع التغيرات في الملف 2
السطر في الكود             .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending
السطر السابق خاص بالعمود المطلوب فرزه  I8  تعنى  بداية فرز البيانات  الصف 8 للعمود  I    تهاية الفرز لتفس العمود الصف 73
الان تريد ان تعدل في السطر حسب الملف2 
الملف 2   المطلوب عمود الفرز M واول صف به بيانات هو الصف 10    فتكتب بدل  M10  -I8  واخر صف 120 فنستبدل  M120 - I73  فيكون السطر النهائي
             .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending
وكذلك يتم التغيير في السطر
 
        .SetRange ws.Range("A8:AH73")                 هذا النطاق يحتوي على جميع الخلايا من العمود A إلى AH ومن الصف 8 إلى 73.
,والملف 2  الخلايا  من العمود Bإلى BAومن الصف 10إلى 120.
فيصبح     SetRange ws.Range("B10:BA120")      
فيصبح الكود النهائي
Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending .SetRange ws.Range("B10:BA120") .Header = xlNo .Apply End With End Sub   بالتوفيق

السلام عليكم 
جرب التعديل في الملف
Option Explicit Sub CircleLowGrades() Dim ws As Worksheet Dim gradeRanges As Variant Dim maxRanges As Variant Dim cell As Range Dim maxCell As Range Dim maxGrade As Double Dim shp As Shape Dim i As Integer, j As Integer Dim gradeRange As Range, maxRange As Range Set ws = ThisWorkbook.Sheets("شهادةنصف") gradeRanges = Array(ws.Range("D13:P13"), ws.Range("D30:P30"), ws.Range("D47:P47")) maxRanges = Array(ws.Range("D12:P12"), ws.Range("D29:P29"), ws.Range("D46:P46")) For Each shp In ws.Shapes If shp.Name Like "Circle*" Then shp.delete Next shp For i = LBound(gradeRanges) To UBound(gradeRanges) Set gradeRange = gradeRanges(i) Set maxRange = maxRanges(i) For j = 1 To gradeRange.Cells.Count Set cell = gradeRange.Cells(j) Set maxCell = maxRange.Cells(j) If IsNumeric(maxCell.Value) Then maxGrade = Val(maxCell.Value) Else maxGrade = 0 End If If IsNumeric(cell.Value) Then If Val(cell.Value) < maxGrade Then Call DrawCircle(ws, cell) End If ElseIf cell.Value = "غ" Or cell.Value = "غـ" Or cell.Value = "صفر" Then Call DrawCircle(ws, cell) End If Next j Next i End Sub Sub DrawCircle(ws As Worksheet, cell As Range) Dim shp As Shape Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left + 2, cell.Top + 2, cell.Width - 4, cell.Height - 4) shp.Name = "Circle" & cell.Address(False, False) shp.Line.ForeColor.RGB = RGB(255, 0, 0) shp.Fill.ForeColor.RGB = RGB(255, 255, 255) shp.Fill.Transparency = 1 End Sub test1.xlsb

، الصورة التي أرفقتها تُظهر 4 أزرار في مربع الحوار، وهو شيء غير ممكن عند استخدام MsgBox مباشرة في VBA، حيث يدعم MsgBox فقط حتى 3 أزرار كحد أقصى.

السلام عليكم
اوافق  استاذتا ابو عيد  على ما تفضل به
ولكن احيانا لائحة الدراسة والامتحانات تنص على هذه الطريقة
على كل حال
من اكواد وكنوز المنتدى  فيه طلبك ان شاء الله
ترتيب التلاميذ تصاعديا (1).xlsm
 

السلام عليكم
جزاك الله خيرا على دعائك
جرب التعديل في المرفق
وان لم يكن الامر هو المطلوب فاعذرنى 
قال توقف تفكيري وتركيزي
ياريته معاي توقف وبس
مش لاقيه خالص
تحياتي
sample.xlsb (1) (1).xlsm