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

وعليكم السلام ورحمة الله وبركاته
الطريفة الاولى
قبل حفظ الملف ارجع الى الصفحة الرئيسية ثم حفظ
الطريقة الثاتية عن طريق كود  وسيقوم بفتح الصفحة الرئيسية  حتى لو قمت بالحفظ عند ورقة 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
 

يالرغم اننا لا نعلم اصدار الاكسل لديك ولكن الملف المرفق  به كود للاصدار القديم 2003  فنا فوق وتم حفظه  شيت .xls لينعامل مع الاصدار 2003
فكرة الكود
الكود  اذا كانت L6 و N6 فارغتان ينم طباعة كل الاستمارات
اذا تم تحديد الخليتين  مدى معين لعدد معين من الطلبة يتم طباعة المحدد فقط
مع عدم المساس بالمعادلات الموجودة بلالاستمارة
اعلمنى بالنتائج بعد التجربة 
شيت نتيجة.xls

السلام عليكم 
جرب الملف
تعديل كود.xlsm

وعليكم السلام ورحمة الله وبركاته
الكود 
Sub تجميع_البيانات() Dim wsSummary As Worksheet Dim ws As Worksheet Dim lastRow As Long Dim summaryLastRow As Long Dim dataRange As Range On Error Resume Next Set wsSummary = ThisWorkbook.Sheets("ملخص") On Error GoTo 0 If wsSummary Is Nothing Then Set wsSummary = ThisWorkbook.Sheets.Add wsSummary.Name = "ملخص" End If wsSummary.Rows("3:" & wsSummary.Rows.Count).ClearContents summaryLastRow = 3 For Each ws In ThisWorkbook.Sheets If ws.Name <> wsSummary.Name Then lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastRow >= 3 Then Set dataRange = ws.Range("A3:Q" & lastRow) wsSummary.Cells(summaryLastRow, "A").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value summaryLastRow = summaryLastRow + dataRange.Rows.Count End If End If Next ws MsgBox "تم تجميع البيانات !", vbInformation End Sub الملف 
Book1.xlsb
 

وعليكم السلام ورحمة الله وبركاته
حسب فهمى لطلبك اليك الملف
مثال (1).xlsm
 

السيد  Khorsheed Omar
المعادلة
=IF([@[الاسم الثلاثي]]<>""; VLOOKUP([@[الاسم الثلاثي]]; 'البيانات الأساسية'!$A$2:$R$100;MATCH("2.2025"; 'البيانات الأساسية'!$1:$1; 0); FALSE); "") 1رواتب.xlsm

وعليكم السلام ورحمة الله وبركاته
طريقتان واختاري ما يتاسبك
الاولى ان يكون الملفان مفتوحان في نفس الوقت ونفس المجلد وبنفس الاسم   تحديث عدد الطلاب2 ( يمكن تعديله من الكود) 
ملف الطلاب الاصل.xlsb
الثانية الملف مقفول وبأي اسم بمعنى عند الضغط على زر تحديث البيانات تظهر واجهة نخنار الملف المراد اخد البيانات منه
ملف الطلاب الاصل2.xlsb
اتمنى ان يكون طلبك في احد الملفين
لك كل التقدير والاحترام

اخي العزيز
إضافة العمود المساعد  لتحسين قابلية التعامل مع البيانات باستخدام المعادلات العادية (بدلاً من الصفيفية). 
عندما نريد تصفية البيانات (مثل ملفك)، يمكننا استخدام معادلات مثل INDEX وMATCH لتحديد الصفوف المطلوبة. ومع ذلك، هذه المعادلات تحتاج إلى طريقة لمعرفة الصفوف التي تحقق الشرط.
العمود المساعد يعمل كـ "علامة" تحدد الصفوف التي تحقق الشرط (J9 < D2) وتُظهر رقم الصف الخاص بها. وإذا لم يتحقق الشرط، يُظهر العمود قيمة فارغة ("") القيم الموجودة في العمود X  هي رقم الصف الذي ينحقق به الشرط في D2 طبعا يمكن الاستغناء على العمود المساعد باستخدام معادلات صفيفية أو حلول برمجية (مثل VBA) والعمود المساعديساعد على تحسين الأداء في النسخ القديمة من Excel مثل 2010 النسخ الحديثة 2019 وما فوق يمكن استخذام دالة FILTER وحقيقة انا لا املك في جهازي الا اصدار 2016 فلا يمكننى التجربة واخير يبقى الكود افضل مم سبق دكره واسرع ويمكن ان يكون تلقائيا بدون زر اليك ملف به  حلات اخران الاول بمعادلات عادية بدون عمود مساعد والاخ على اليسار بالمعادلات الصفيفية 1شيت.xlsx  حل اخر ويعنبر افضلهم بدون معادلات وبدون زر .عند الكنابة في D2 تتم الفلترة للدرجات ولا تنسى تمكين الماكرو شيت1.xlsb اتمنى  فيما دكر بعض الفائدة نحياتي