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

الاجابة في المشاركة التالية

وعليكم السلام ورخمة الله وبركاته
جرب  هذا الكود
Sub MergeSheets_Total() Dim ws As Worksheet, wsTotal As Worksheet Dim i As Long, destRow As Long Dim dateValue As Variant Dim r As Long, lastDataRow As Long Dim sheetName As String On Error Resume Next Set wsTotal = ThisWorkbook.Sheets("TOTAL") On Error GoTo 0 If wsTotal Is Nothing Then MsgBox "لم يتم العثور على الشيت TOTAL", vbCritical Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False wsTotal.Range("A3:F320").ClearContents destRow = 3 For i = 1 To 31 sheetName = Format(i, "00") On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If Not ws Is Nothing Then lastDataRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastDataRow >= 4 Then dateValue = ws.Range("B1").Value For r = 4 To lastDataRow If Trim(ws.Cells(r, "A").Value) <> "" Then wsTotal.Cells(destRow, "B").Resize(1, 5).Value = ws.Cells(r, "A").Resize(1, 5).Value wsTotal.Cells(destRow, "A").Value = dateValue destRow = destRow + 1 End If Next r End If End If Set ws = Nothing Next i Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub The Safe1.xlsb
 

وعليكم السلام ورحمة الله وبركاته
 
 الكود يرتب حسب العمود H  اولا ث ثم يرتب حسب العمود C
Sub SortByColumn() Dim ws As Worksheet Dim rng As Range Dim lastRow As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rng = ws.Range("A3:S" & lastRow) With ws.Sort .SortFields.Clear .SortFields.Add Key:=rng.Columns(8), Order:=xlAscending .SortFields.Add Key:=rng.Columns(3), Order:=xlAscending .SetRange rng .Header = xlNo .Apply End With End Sub اتمنى ان تجد فيه طلبك
 

السلام عليكم ورحمة الله وبركاته 
يمكن بواسطة معادلة   
=IFERROR(AVERAGEIFS(table1!$A:$A; table1!$C:$C; $C5; table1!$E:$E; D$4);"") او كود يفوم بجلب الاصناف مع متوسط كل صنف
Sub حساب_المتوسط_و_جلب_الاصناف() Dim wsIn As Worksheet, wsOut As Worksheet Dim lastRowIn As Long Dim dataArr As Variant Dim i As Long Dim prod As String, price As Double Dim dt As Variant, mon As Long Dim sums As Object, counts As Object, uniqueProds As Object Dim key As String Dim prodList As Variant Dim r As Long, c As Long Dim lastRowOut As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wsIn = Sheets("table1") Set wsOut = Sheets("sheet1") Set sums = CreateObject("Scripting.Dictionary") Set counts = CreateObject("Scripting.Dictionary") Set uniqueProds = CreateObject("Scripting.Dictionary") lastRowIn = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row If lastRowIn < 2 Then Exit Sub dataArr = wsIn.Range("A2:D" & lastRowIn).Value For i = 1 To UBound(dataArr, 1) prod = CStr(dataArr(i, 3)) dt = dataArr(i, 4) If Len(prod) > 0 And IsDate(dt) Then mon = Month(dt) price = dataArr(i, 1) key = prod & "_" & mon If Not sums.Exists(key) Then sums(key) = 0 counts(key) = 0 End If sums(key) = sums(key) + price counts(key) = counts(key) + 1 If Not uniqueProds.Exists(prod) Then uniqueProds(prod) = True End If End If Next i wsOut.Range("C5:C10000").ClearContents prodList = uniqueProds.Keys For i = 0 To UBound(prodList) wsOut.Cells(5 + i, "C").Value = prodList(i) Next i lastRowOut = wsOut.Cells(wsOut.Rows.Count, "C").End(xlUp).Row For r = 5 To lastRowOut prod = wsOut.Cells(r, "C").Value For c = 4 To 15 mon = wsOut.Cells(4, c).Value key = prod & "_" & mon If sums.Exists(key) Then wsOut.Cells(r, c).Value = sums(key) / counts(key) Else wsOut.Cells(r, c).ClearContents End If Next c Next r Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub تحيانى لك ولمعلمنا الفاضل أ / محمد صالح
متوسط الاصناف كود.xlsb
متوسط الاصناف معادلة.xlsx
 

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