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

وعليكم السلام ورحمة الله وبركاته 
=IFERROR(AGGREGATE(15;6;A4:A30;ROW($A$1));"") السبب الرئيسي هو أن ROW($A$1) ثابت دائماً  وكذلك النطاق يجب ثتبيته بحيث لا يتغير عند السحب ليصبح A$4:A$30 بدل A4:A30
ولحل المشكلة  اختر احدى المعادلات
=IFERROR(AGGREGATE(15;6;A$4:A$30;ROW(A1)-ROW(A$1)+1);"") =IFERROR(AGGREGATE(15;6;$A$4:$A$30;ROW(A1));"") =IFERROR(AGGREGATE(15;6;$A$4:$A$30;ROW(A1:A1));"") =IFERROR(AGGREGATE(15;6;$A$4:$A$30;ROW(A4)-ROW($A$4)+1);"") اليك الملف وبه تطبيق المعادلات الاربعة السابقة
ntega_elec_new.xlsb
 

وعليكم السلام ورحمة الله وبركاته
قمت ياستبدال اللستبوكس بالورقة باخر في يوزرفورم
فكرة العمل
انقر على الخلية المراد وضع الوظيفة بها في العمود B يظهر الفورم قم بالاختيار  ويختفى الفورم عند النقر في اي خلية اخرى
لك وافر الاحترام والتقدير
LISTBOX1.xlsm
 

السلام عليكم ورحمة الله وبركاته
ساقدم لك ملف خسب ما فهمته من ردك  
راجع الملف واذا كانت هناك قيم غير صحيحة  فقم  بارفاق جدول به القيم الصحيحة يدويا وبدون معادلات  للراتب والسلفيات لعدد 3 او 4 اشخاص  
اليومية (2).xlsm

وعليكم السلام ورحمة الله وبركاته
المشكلة الرئيسية  هي في منطق البحث
 
البحث عن الأعمدة يتم من الصف 3 (G3:U3) ولكن البيانات تبدأ من الصف 4
الإزاحة (offset) غير صحيحة عند استخراج القيم
اليك التعديل
تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm
 

السلام عليكم
جرب الملف 
TRIP_01 (1) (2).xlsx
 

السلام عليكم
استبدل هذا
Private Sub UserForm_Initialize() Call showinlistbox End Sub بهذا
Private Sub UserForm_Initialize() TextBox25 = Val(Sheets("table").Cells(Rows.Count, 1).End(xlUp).Value) Call showinlistbox End Sub   TextBox25 = Val(Sheets("table").Cells(Rows.Count, 1).End(xlUp).Value)

وعليكم السلام ورحمة الله وبركاته
دالة COUNTA (لا تعمل مع التصفية)
دالة SUBTOTAL وهي في حالتين 
=SUBTOTAL(3, A1:A10)  
 تقوم بعدّ كل القيم غير الفارغة في A1:A10 حتى المخفية. اي لا تعمل مع التصفية
=SUBTOTAL(103, A1:A10) تقوم بعدّ القيم غير الفارغة فقط في الصفوف الظاهرة بعد التصفية أو الإخفاء اي  تعمل مع التصفية
الرقم 103: يمثل (عدّ القيم غير الفارغة) مع تجاهل الصفوف المخفية يدويًا أو بواسطة التصفية.
 
اليك طلبك 
05- محرك بحث يعمل على تصفية البيانات حسب كل خلية على حدى 23-10-2025.xlsm

وعليكم السلام ورحمة الله وبركاته
تم وضع معادلات في العمود G وكذلك العمود J
نموذج.xlsx

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