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

السلام عليكم
ساشرح لك بمثال 
لنفرض ان الملف 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 اتمنى  فيما دكر بعض الفائدة نحياتي

السلام عليكم
dashboared موضوع يحناج الى من يتقن اعداد الجدوال بالاكسل   مثل جدول الموظفات الجدد في صفحة  وجدول المواضيع في صفحة وجدول الاجتماعات في صفحة
واستخدام معادلة COUNTIF لحساب عدد الموظفات وعدد المواضيع المفعلة وغيرها
ثم بانشاء صفحة داش بورد والتي تتطلب منك 
اتقان الرسوم البيانية   والجداول المحورية  والتي يكون مصدر بياناتها   الصفحات الاخري 
عند النغيير في اي بيان في الصفحات يتم تغييره تلقائيا في الرسوم البيانية والجداول المحورية
ابحثى في اليوتيوب به الكثير من الدروس  هذا احداها
 
 
اليك ملف يمكنك التعديل عليه
dashboared.xlsx
 

السلام عليكم
قم بتفعيل الماكرو
الكود
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$G$2" Then Dim wsReport As Worksheet Dim wsSearch As Worksheet Dim lastRow As Long Dim i As Long Dim searchDate As Date Set wsReport = ThisWorkbook.Sheets("REPORT") Set wsSearch = ThisWorkbook.Sheets("Search2") searchDate = wsSearch.Range("G2").Value wsSearch.Range("B4:G1000").ClearContents lastRow = wsReport.Cells(wsReport.Rows.Count, "D").End(xlUp).Row Dim rowIndex As Long rowIndex = 4 For i = 2 To lastRow If wsReport.Cells(i, "D").Value = searchDate Then wsSearch.Cells(rowIndex, "B").Value = rowIndex - 3 wsSearch.Cells(rowIndex, "C").Value = wsReport.Cells(i, "G").Value wsSearch.Cells(rowIndex, "F").Value = wsReport.Cells(i, "J").Value wsSearch.Cells(rowIndex, "D").Value = wsReport.Cells(i, "I").Value wsSearch.Cells(rowIndex, "E").Value = wsReport.Cells(i, "H").Value rowIndex = rowIndex + 1 End If Next i End If End Sub New Microsoft Excel Worksheet (1).xlsb

السلام عليكم 
الحمد لله تم اصلاح العطل بالمنتدى
 
بواسطة  فلترة البيانات بالعمود الاول A يمكن تعديل حسب العمود الذي به بيانات في الجزء 
Field:=1 الكود 
 
Sub SaveRangeAsPDF() Dim ws As Worksheet Dim savePath As String Set ws = ThisWorkbook.Sheets("ورقة1") With ws .Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "D:\" & .Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" .Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False .AutoFilterMode = False End With MsgBox "تم حفظ الملف بنجاح!", vbInformation, "حفظ PDF" End Sub الملف 
DFP2.xlsb

السلام عليكم
دالة countif مضافاً إليها دالة max  ضعها في a2 ثم اسحبها للاسفل
=IF(COUNTIF($B$2:B2; B2)=1; MAX($A$1:A1)+1; "") ملف
ترقيم بتجاوز المكرر.xlsx

وعليكم السلام ورحمة الله وبركاته
="D:\الهويات\Pictures\" & ROW(A1) & ".jpg" ثم لسحب للاسفل
ويمكنك نسخها ولصقها كقيم يعد ذلك
New Microsoft Excel Worksheet.xlsx

السلام عليكم  
 بعض الاقسام غير موجودة  يمكنك اظافتها وسحب المعادلة اليها
تقرير.xlsx

تم عمل البحث بالمدينة وعدم تكرار رقم البطاقة 
كروت_07.xlsb

السلام عليكم 
يمكن عن طريق رسم دائرة على الخلية
الكود  
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column > 7 And Target.Column < 31 And Target.Row > 5 Then Cancel = True Dim ws As Worksheet Set ws = ActiveSheet Dim shp As Shape For Each shp In ws.Shapes If Not Intersect(shp.TopLeftCell, Target) Is Nothing Then shp.Delete End If Next shp With ws.Shapes.AddShape(msoShapeOval, Target.Left, Target.Top, Target.Width, Target.Height) .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) End With End If End Sub الملف 
دائرة حمراء.xls
 

السلام عليكم
تم التعديل ان شاء الله
عمل احصائية.xlsm

وعليكم السلام ورحمة الله وبركانه
اضطررت الى تعديل الجدول قليلا في صفحة جدوال الشرائح 
الكود
Sub CalculateRanges() Dim wsClients As Worksheet Dim wsRanges As Worksheet Dim lastRowClients As Long Dim i As Long, j As Long, k As Long Dim count As Long Dim total As Double Dim depositValue As Double Dim rangeStart As Double Dim rangeEnd As Double Dim ranges As Variant Dim colIndex As Variant Dim infiniteRows As Variant Set wsClients = ThisWorkbook.Sheets("العملاء") Set wsRanges = ThisWorkbook.Sheets("جدوال الشرائح") lastRowClients = wsClients.Cells(wsClients.Rows.count, 1).End(xlUp).Row ranges = Array(Array(3, 7, 3), Array(10, 14, 4), Array(17, 21, 5), Array(24, 28, 6), Array(31, 35, 7)) infiniteRows = Array(7, 14, 21, 28, 35) For k = LBound(ranges) To UBound(ranges) wsRanges.Range("D" & ranges(k)(0) & ":F" & ranges(k)(1)).ClearContents For i = ranges(k)(0) To ranges(k)(1) rangeStart = wsRanges.Cells(i, "B").Value If IsInArray(i, infiniteRows) Then rangeEnd = Application.WorksheetFunction.Large(wsClients.Range("C2:C" & lastRowClients), 1) * 10 ' اعتبار القيمة ما لا نهاية Else rangeEnd = wsRanges.Cells(i, "C").Value End If count = 0 total = 0 For j = 2 To lastRowClients depositValue = wsClients.Cells(j, ranges(k)(2)).Value If depositValue >= rangeStart And depositValue <= rangeEnd Then count = count + 1 total = total + depositValue End If Next j wsRanges.Cells(i, "D").Value = count wsRanges.Cells(i, "E").Value = total Next i wsRanges.Cells(ranges(k)(1) + 1, "D").Formula = "=SUM(D" & ranges(k)(0) & ":D" & ranges(k)(1) & ")" wsRanges.Cells(ranges(k)(1) + 1, "E").Formula = "=SUM(E" & ranges(k)(0) & ":E" & ranges(k)(1) & ")" Next k End Sub Function IsInArray(valueToFind As Variant, arr As Variant) As Boolean Dim i As Long For i = LBound(arr) To UBound(arr) If arr(i) = valueToFind Then IsInArray = True Exit Function End If Next i IsInArray = False End Function الملف 
شرائح.xlsb

الله يحفظك
=IF(J15 < 0; "المبلغ ناقص"; "المبلغ كامل") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

المقصود عند دخول الورقة قائمة الاسماء  قي العمود D كلما اضفت اسما او اكثر ولو كان مكررا تجده في القائمة في الخلية
وهذا ما يقوم به الكود حاليا  عند تغيير الاسم في الخلية I6  نجد مجموع الرواتب في M6 ومجموع السلف في M7  للموظف 
اذا كانت بياناتك بسيطة فمعادلان  اما اذا كانت كبيرة فانصحك بالكود
على كل حال  اليك الحل عن طريق المعادلات ولك الخيار في استخدام ما يفيدك في عملك
DC (1).xlsx

وعليكم السلام ورحمة الله وبركانه 
الملف
____أرقام الجلوس والمناداة - 2025 الرابع.xlsm