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

وعليكم السلام ورحمة الله وبركاته
اليك التعديل حيث الكود يتعامل مع الخلايا المدمجة 
Private Sub CommandButton2_Click() On Error GoTo ErrorHandler Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("Sheet4") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsSource .Range("B3:G3").ClearContents .Range("G4:G6").ClearContents .Range("D4:E6").ClearContents .Range("C11:G17").ClearContents .Range("C21:G27").ClearContents .Range("C31:G34").ClearContents .Range("B37:G43").ClearContents .Range("B47:G51").ClearContents .Range("C54:G54").ClearContents .Range("C57:G59").ClearContents .Range("B61:G68").ClearContents End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "حدث خطأ: " & Err.Description End Sub  

وعليكم السلام ورحمة الله وبركاته
اليك الملف وبه كود  فيه طلبك باذن الله
مجموع1.xlsb
لك تفديري واحترامي

وعليكم السلام ورحمة الله وبركاته 
اعتقد تقضد العمود E  فهو مخصص لايام الغياب خسب ملفك 
الكود يحسب جميع الأيام المتتالية  السابقة بما في ذلك يوم التاريخ المحدد ولا يخسب الايام التالية بعد التاريخ المحدد
اليك الملف 
 
test1.xlsb

وعليكم السلام ورخمة الله وبركاته
اليك التعديل وارجو ان يكون فيه طلبك
غياب 1طلاب.xlsb
تحياتي

وعليكم السلام ورحمة الله وبركاته
الملف المرفق مقال لجداول 3  كلمة السر للاول111 والثاني 222 والثالت 333
يمكن تعديلها من الكود ويمكنك قفل محرر الاكواد بكلمة سر
فكرة الكود عند الدخول على الصفخة يتم حماية الجدوال  كلها بكلمة سر هي  master   يمكن تعديلها من الكود للجداول 3
يختار الشخص جدوله يطالب بكلمة سر يكتبها فيتعامل مع جدولة وباقي الجداول محمية
يمكنك تعديل  نطاف الجداول في الكود
اتمنى ان تجد في الملف طلبك
تحياتي
حماية جدوال متعددة كل جدول بكلمة سر.xlsb

وعليكم السلام ورخمة الله وبركاته
اخي لا داعي للاعتذار وملقك ليس مبهما وطلبك يتكرر كثيرا في المنتدى  الغموض كان في النتائج المرفقة مع ملفك وخضوصا للسائق اخمد فهي غير صحيحة
الملفان السابقان فيهما طلبك ولكن بزر وليس تلقائي  
فكرة عمل الملف المرفق  قم بادخال البيانات لكل السائفين مع العهد والمصروفات ثم استحدم زر الترحيل  فيتم انشاء صفخات للسائقين
 بعدها عند أي تغيير في صفحتي العهدة أو المصروفات، يتم  تحديث جميع صفحات السائقين الموجودة تلفائيا ولا تختاج الى زر الترحيل
 حاليا لديك 3 ملفات كلها تعمل اختر ما يناسب طلبك وكلها تؤدى الى نفس النتيجة 
اتمنى لك التوفيق
جميع السائقين في نفس تلقائي الملف (1).xlsb

نعم استاذى الفاضل Foksh  صدفت وشكرا لتنبيهك 
كما اشكر صاخب السؤال الفاضل soik225998 على تنبيهنا للامر
تم معالجة الامر ان شاء الله
المرشحين2.xlsb
 

اليك التعديل   كلمة المرور 1234
اظافة زر تعديل وخذف للفورم.xlsm

اعتقد تعنى الفورم1 
اظهار العناوين في LISTBOX.xlsm

السلام عليكم 
صباح الخير استاذ خيري
الحل سيكون عن طريق فورم بمعنى 
عند البحث  سواء بالرقم الاشاري او باي جزء من النص ، إذا وجد نتيجة واحدة سيتم تعبئتها مباشرة بدون ظهور الفورم
إذا وجد أكثر من نتيجة، سيظهر الفورم بعرض تص الرسالة والرقم الاشاري
يمكنك الاختيار بالنقر المزدوج أو بالاختيار من اللست ثم زر "تحديد"
تحياني
االمراسلات الإدارية2.xlsm

وعليكم السلام ورحمة الله وبركاته
جرب هذا التعديل
مخزن3 (1).xlsm
 

وعليكم السلام ورحمة الله وبركاته
اسعدنى ان الملف يعمل لديكم
تم اظافة زر جديد لطلبك الاخير وتم ترتيب الاسماء ابجديا مع التجميع الكلي لكل العملاء مع امكانية الطباعة والتحويل الى PDF والمعاينة

 
متابعة (3).xlsm

السلام عليكم
 جرب التعديل التالي
التعديل في الجزء 
wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True الى
wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True الكود كاملا
Sub CopyPrintClear() Dim wsArchive As Worksheet Dim wsPrint As Worksheet Dim lastRow As Long Dim copyRange As Range Dim rowCount As Long Dim i As Long Dim Password As String Dim requiredCells As Variant Dim cell As Variant Dim isIncomplete As Boolean Password = "KHORSHEED.OMAR.2025" ' تعيين الشيتات Set wsPrint = ThisWorkbook.Sheets("طباعة") Set wsArchive = ThisWorkbook.Sheets("أرشيف") ' التحقق من الخلايا المطلوبة requiredCells = Array("A2", "F2", "F3", "C18") isIncomplete = False For Each cell In requiredCells If Trim(wsPrint.Range(cell).Value) = "" Then isIncomplete = True Exit For End If Next cell If isIncomplete Then MsgBox "الملف غير كامل. يرجى تعبئة جميع الخلايا المطلوبة.", vbExclamation Exit Sub End If ' رسالة تأكيد If MsgBox("هل تريد تنفيذ العملية؟", vbYesNo + vbQuestion, "تأكيد") = vbNo Then Exit Sub End If ' رفع الحماية مؤقتًا wsArchive.Unprotect Password:=Password ' تحديد نطاق النسخ Set copyRange = wsPrint.Range("A6:G15") rowCount = copyRange.Rows.Count ' تحديد أول صف فارغ في شيت الأرشيف lastRow = wsArchive.Cells(wsArchive.Rows.Count, "B").End(xlUp).Row + 1 ' نسخ الجدول بالكامل إلى الأرشيف wsArchive.Range("A" & lastRow).Resize(rowCount, 5).Value = copyRange.Value ' نسخ القيم الفردية إلى الأعمدة المطلوبة wsArchive.Range("F" & lastRow & ":F" & lastRow + rowCount - 1).Value = wsPrint.Range("C18").Value wsArchive.Range("J" & lastRow & ":J" & lastRow + rowCount - 1).Value = wsPrint.Range("B3").Value wsArchive.Range("H" & lastRow & ":H" & lastRow + rowCount - 1).Value = wsPrint.Range("F3").Value wsArchive.Range("G" & lastRow & ":G" & lastRow + rowCount - 1).Value = wsPrint.Range("F2").Value wsArchive.Range("I" & lastRow & ":I" & lastRow + rowCount - 1).Value = wsPrint.Range("A2").Value ' تحديد منطقة الطباعة وشطبها wsPrint.PageSetup.PrintArea = "$A$1:$F$18" wsPrint.PrintOut ' مسح البيانات من الشيت wsPrint.Range("A6:A15").ClearContents wsPrint.Range("C6:E15").ClearContents wsPrint.Range("A2").ClearContents wsPrint.Range("F2").ClearContents wsPrint.Range("F3").ClearContents wsPrint.Range("C18").ClearContents ' الطباعة مرة ثانية إذا رغبت wsPrint.PageSetup.PrintArea = "$A$1:$F$18" wsPrint.PrintOut wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True ' تنظيف الحافظة Application.CutCopyMode = False ' العودة إلى شيت الطباعة وتحديد الخلية A1 wsPrint.Activate wsPrint.Range("A1").Select End Sub  

في طلبك الاول TextBox8 فقط  والان تغير الطلب  الى الكمبوبكس
يمكن اظافة   التالي الى UserForm_Initialize
Dim ctrl As Control For Each ctrl In Me.Controls If TypeName(ctrl) = "ComboBox" Then ctrl.Style = fmStyleDropDownList ctrl.Locked = False End If Next ctrl  
برنامج المراكز الطبية 30 اغسطس.xlsm

وعليكم السلام ورخمة الله وبركاته
ربما تفصد اخفاء الاعمدة   وليس الخذف كما ورد في طلبك
الكود يخفى العمود كله فارغ أو كله قيمه تساوي (0 أو 0%) → يخفي العمود بالكامل.
الكود في البداية يظهر كل الأعمدة ثم يعيد إخفاء المناسب
تم ربط الكود مع امر الفلترة 
اظافة التسطير لناتج الفلترة
هذا خسب فهمى لطلبكم
الكود 
Sub فلترة_اخفاء() Dim wsSrc As Worksheet, wsDst As Worksheet Dim lastRow As Long Dim rng As Range, col As Range, c As Range Dim hideCol As Boolean Dim rngOut As Range Application.ScreenUpdating = False Set wsSrc = ThisWorkbook.Sheets("المجمع") Set wsDst = ThisWorkbook.Sheets("1") lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then wsDst.Rows("5:" & lastRow).ClearContents wsDst.Rows("5:" & lastRow).ClearFormats End If wsDst.Columns("A:W").Hidden = False lastRow = wsSrc.Cells(wsSrc.Rows.Count, "E").End(xlUp).Row If lastRow < 2 Then Exit Sub wsSrc.Range("E1:W" & lastRow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsDst.Range("Criteria"), _ CopyToRange:=wsDst.Range("Extract"), _ Unique:=False lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then GoTo Done Set rngOut = wsDst.Range("A5:W" & lastRow) With rngOut.Borders .LineStyle = xlContinuous .Color = vbBlack .Weight = xlThin End With rngOut.EntireColumn.Hidden = False For Each col In rngOut.Columns hideCol = True For Each c In col.Cells If Not (isEmpty(c.Value) Or c.Value = 0 Or c.Text = "0%") Then hideCol = False Exit For End If Next c If hideCol Then col.EntireColumn.Hidden = True Next col Done: Application.ScreenUpdating = True End Sub الملف
W1.xlsm
تحياتي
 
 

السلام عليكم 
كود طباعة وكود تحويل pdf
Sub Print_Managers_Deputies() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim idVal As String, roleVal As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow idVal = wsData.Cells(i, "A").Value roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("L2").Value = idVal wsReport.PrintOut wsReport.Range("L2").Value = 1 End If Next i MsgBox "تمت طباعة جميع المديرين والوكلاء.", vbInformation Application.ScreenUpdating = True Application.EnableEvents = True End Sub Sub sav_PDFall2() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim roleVal As String Dim folderPath As String, pdfPath As String Dim safeName As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") wsReport.Unprotect password:="0" folderPath = ThisWorkbook.Path & "\التقرير مدير وكيل" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("C9").Value = wsData.Cells(i, "B").Value safeName = wsReport.Range("C9").Value safeName = Replace(safeName, "/", "-") safeName = Replace(safeName, "\", "-") safeName = Replace(safeName, ":", "-") safeName = Replace(safeName, "*", "-") safeName = Replace(safeName, "?", "-") safeName = Replace(safeName, """", "-") safeName = Replace(safeName, "<", "-") safeName = Replace(safeName, ">", "-") safeName = Replace(safeName, "|", "-") pdfPath = folderPath & "\" & safeName & ".pdf" wsReport.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=pdfPath, _ Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "تم حفظ جميع ملفات PDF للمديرين والوكلاء في:" & vbCrLf & folderPath, vbInformation wsReport.Protect password:="0" Application.ScreenUpdating = True Application.EnableEvents = True End Sub الملف
 
طباعة وظائف محددة.xlsm

وعليكم السلام ورحمة الله وبركاته 
تم انشاء كود الطباعة والمعاينة 
اتمنى ان  تجد في الحل طلبك
لك وافر الاحترام
Sub Print_All_Employees() Dim ws As Worksheet Dim cell As Range Dim rng As Range Set ws = ThisWorkbook.Sheets("إداريين") Set rng = ws.Range("C3:C137") Application.ScreenUpdating = False For Each cell In rng If cell.Value <> "" Then ws.Range("CQ6").Value = cell.Value ws.PageSetup.PrintArea = "CP5:CY47" ws.PrintOut End If Next cell ws.Range("CQ6").Value = rng.Cells(1, 1).Value Application.ScreenUpdating = True MsgBox "تمت طباعة جميع الموظفين بنجاح.", vbInformation End Sub طباعة الكل بضغطة.xlsm

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

وعليكم السلام ورخمة الله وبركاته
جرب  هذا الكود
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 ثواني
لك كل التقدير والاحترام