hegazee

بارك الله فيك أستاذ أحمد
. كما تفضلت حضرتك بالملف فإن معادلة العلامة خبور رائعة و تصلح لهذا الملف تماما فقط قم بنسخ الكود التالي في موديل جديد في  في محرر الأكواد
Function kh_Names(FullName As String, ParamArray iNdex1()) As String Dim i As Integer Dim kh_Split, MyArray, Ar Dim Kh_String As String, Sn As String, Re As String On Error GoTo Err_Kh_Names '====================================== MyArray = Array("عبد ", "أبو ", "ابو ", "آل " _ , " الله", " الدين", " الإسلام", " الاسلام", " الحق") '====================================== Sn = Application.WorksheetFunction.Trim(FullName) For Each Ar In MyArray Re = Replace(Ar, " ", "^") Sn = Replace(Sn, Ar, Re) Next '====================================== kh_Split = Split(Sn, " ", , vbTextCompare) On Error Resume Next For i = 0 To UBound(iNdex1) Kh_String = Kh_String & " " & kh_Split(iNdex1(i) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") kh_Names = Kh_String Exit Function Err_Kh_Names: kh_Names = "" End Function ثم  ضع المعادلة التالية في خانة اسم الأب مثلا:
=kh_Names(H9;2;3;4;5) مع مراعاة الفاصلة عادية أو منقوطة حسب اصدار الاوفيس
مجمع 2026بعد نتيجة ثالثة.xlsm

تفضل الملف و جرب كتابة اسماء بها عبد في العمود  الثالث و طبق عليها ما تريد
حذف المسافات(1).xlsm

أولا تم تعديل المعادلة لتكون:
=IF(G2="";"";IF(G2<1;"أقل من فدان";IF(AND(G2>=1; G2<3);"من 1 إلى أقل من 3 فدان";IF(AND(G2>=3; G2<5);"من 3 إلى أقل من 5 فدان";IF(AND(G2>=5; G2<10);"من 5 إلى أقل من 10 فدان";IF(AND(G2>=10; G2<20);"من 10 إلى أقل من 20 فدان";IF(AND(G2>=20; G2<=25);"من 20 إلى 25 فدان";"أكثر من 25 فدان"))))))) شرح المعادلة: تستخدم الدالة IF   بشكل متداخل لتصنيف قيمة موجودة في الخلية G  إلى فئات مختلفة بناء على مدى هذه القيمة مع افتراض أن القيمة تمثل مساحة بالأفدنة تماما مثل إظهار نتيجة الطلاب بالتقديرات
IF(G2="";"")
إذا كانت الخلية G2 فارغة، فإن الناتج يكون فارغًا أيضا لا يعرض شيء.
هذا يجنب ظهور نتائج غير مرغوبة عند عدم وجود بيانات.
IF(G2<1;"أقل من فدان")
إذا كانت القيمة في G2 أقل من 1 لكن ليست فارغة يعرض:
"أقل من فدان".
IF(AND(G2>=1; G2<3)
إذا كانت القيمة أكبر من أو تساوي 1 ولكن أقل من 3 يعرض:
"من 1 إلى أقل من 3 فدان".
  وهكذا باقي المساحات
أما المعادلة
=IF(AND(ISNUMBER(D2); ISNUMBER(E2); ISNUMBER(F2)); F2 + E2/24 + D2/576; "")  
تستخدم لتحويل وحدات الأراضي (الفدان، القيراط، السهم) إلى قيمة عشرية واحدة تعبر عن المساحة الكلية بالفدان.
الوحدات المستخدمة في مصر:
الفدان (F2) ← الوحدة الأساسية. القيراط (E2) ← 1 فدان = 24 قيراط. السهم (D2) ← 1 قيراط = 24 سهم → إذن 1 فدان = 576 سهم (24 × 24)  
ثانيا: ملفك الأصلي فيه بعض الملاحظات فهناك صفوف فارغة تماما و أيضا الخلايا فارغة ليس بها أي رقم المفروض نضع صفر في الخلايا الفارغة لتدخل ضمن حساب المعادلة
أيضا هناك أسماء لا تملك حتى سهم و بالتالي لا تدخل ضمن الأفراد ذوي الملكية
بعد التعديلات ستلاحظ أن العدد مضبوط
فئات الانتفاع2.xlsx

تأكد من إعدادت اللغة للجهاز و أن اللغة العربية ممكنة
افتح خيارات الاكسيل و تأكد منها

تفضل ملف محدث به كل ما طلبت 
أما بخصوص تعلم الأكواد فالموضوع بسيط و لكن يلزمه شغف التعلم مع المحاولة و الخطأ
أجازات 3.xlsm

تفضل الملف جاهز
طرح الأيام 
=DATEDIF(R16;O16;"MD") طرح الشهور
=DATEDIF(R16;O16;"YM") طرح السنوات
=DATEDIF(R16;O16;"Y") لجمع السنوات
=DATE(YEAR(O28) + T28; MONTH(O28) + S28; DAY(O28) + R28)  
جمع (2).xlsx

ممكن يكون من إعدادت اللغة
فتح:
لوحة التحكم > المنطقة (Region) > الإدارة (Administrative)
اضغط:
تغيير الإعدادات المحلية للنظام (Change system locale...)
اختر:
العربية (Egypt) أو العربية (Saudi Arabia) حسب منطقتك.
أعد تشغيل الجهاز.

جرب هذا الكود
Sub Hyperlink_cut() Dim selectedFile As String Dim result As Variant ' فتح مربع حوار لاختيار الملف With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel المراد قطع الرابط معه" .Filters.Clear .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm" .AllowMultiSelect = False If .Show = -1 Then selectedFile = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف.", vbExclamation Exit Sub End If End With ' محاولة قطع الرابط On Error Resume Next ActiveWorkbook.BreakLink Name:=selectedFile, Type:=xlExcelLinks If Err.Number <> 0 Then MsgBox "تعذر قطع الرابط. تأكد أن الملف مرتبط فعلاً.", vbCritical Exit Sub End If On Error GoTo 0 ' تحديد خلية H9 Range("H9").Select ' تحديد الشكل "Rectangle 4" On Error Resume Next ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select On Error GoTo 0 ' الانتقال إلى المرجع "Macro1" On Error Resume Next Application.Goto Reference:="Macro1" On Error GoTo 0 End Sub  

تفضل أخي الكريم  3 ملفات
الأول إذا كان الأوفيس عندك 365  أو 2016 فيما فوق
الثاني إذا كان الأوفيس إصدار أقل من 2016
الثالث باستخدام الأكواد
لا تنسى اختيار "اختر تمت الاجابة"  إذا تم حل المشكلة
استخراج_فواتير_بدون_تكرار (365).xlsx استخراج_فواتير_بدون_تكرار (أوفيس قديم).xlsx
استخراج_فواتير_بدون_تكرار (كود).xlsm

تفضل
Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub  

تفضل الملف . حطيت بعض المعلومات العشوائية لاختبار المعادلة
شهر 12022(2).xlsx

تفضل أخي ملفين
الملف الأول: يقوم بطباعة أوراق العمل حسب ما تكتبه من نطاقات في كل رسالة تظهر
الملف الثاني : ما عليك إلا كتابة نطاق طباعة كل صفحة في الخلية A1 و البرنامج يقوم بطباعتها
ملاحظات:
·  إذا اختار المستخدم الطباعة، تطبع جميع الأوراق في دفعة واحدة.
·  إذا اختار حفظ PDF، تنسخ هذه الأوراق إلى مصنف مؤقت ثم يصدر إلى PDF.
*عند التصدير بصيغة PDF اختر مجلد لحفظ ملف الطباعة فيه
*أهم شيء تنسيق الصفحات و الهوامش حيث لاحظت أن بعض الصفحات تتم طباعتها على ورقتين لعدم ضبط المسافات و الحدود
أيضا عند تغيير أسماء أوراق العمل في الملف الأول لابد أن تغيرها في الكود.
 
طباعة اكثر من صفحة.xlsb طباعة اكثر من صفحة من خلال خلية.xlsb

و أنتم بخير . جرب الكود التالي في الملف الأول
Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "ملف 1" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If ' تحديد النطاق من F9 إلى S609 Set OnRng = WSdata.Range("F9:S609") WSdest.Cells.UnMerge WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط OnRng.Copy With WSdest.Range("F9") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("F9"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub  

و عليكم السلام
الكود التالي يحقق المطلوب فقط تأكد من أن الملفين في نفس المسار
 
Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String WSname = "إدخال بيانات أساسية" ' تأكد من أن الاسم مطابق تمامًا On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ' تحديد مسار الملف FilePath = ThisWorkbook.Path & "\Book2.xlsb" ' تأكد من امتداد الملف ' التحقق من وجود الملف If Dir(FilePath) = "" Then MsgBox "ملف Book2 غير موجود في المسار: " & vbCrLf & FilePath, vbExclamation Exit Sub End If ' فتح الملف بكلمة المرور Set Wb1 = Workbooks.Open(FilePath, Password:="123") ' تأكد من كلمة المرور Set Wb2 = ThisWorkbook ' التحقق من وجود ورقة العمل Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "ورقة العمل '" & WSname & "' غير موجودة في أحد الملفين", vbCritical Wb1.Close False Exit Sub End If ' نسخ البيانات Set OnRng = WSdata.UsedRange If OnRng.Cells.CountLarge = 1 And IsEmpty(OnRng.Value) Then MsgBox "لا توجد بيانات في الورقة المصدر", vbExclamation Wb1.Close False Exit Sub End If WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Wb1.Close False MsgBox "تم نسخ البيانات بنجاح", vbInformation ExitHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume ExitHandler End Sub  

نعم، برنامج  الأوفيس ومن ضمنه Excel متوفر بنسختين:
  إصدار 32bit  و إصدار 64bit

الملف المرسل في مشاركة سابقة ممتاز و يعمل بكفاءة و يوزع عدد 2 ملاحظين في كل لجنة برجاء تجربتة و كتابة ملاحظاتك. قمت بتعديل عدد اللجان و الملاحظين ليتوافق مع اللجان عندك
توزيع الملاحظين .xlsm

إليك أخي الملف كما طلبت مع تلوين الخلايا حسب الاختيار
 
تسجيل بيانات2.xlsm

عندي ملف من إعداد الاستاذ مصطفى شرف و قمت بالتعديل عليه
الشرح للأستاذ مصطفى من هنا
 
 
توزيع الملاحظين 2024.xlsm

جرب الملف التالي حسب فهمي للموضوع
جدول 2.xlsx

جرب المعادلة التالية
=IF($B10="","",ROUND(VLOOKUP($B10,nageh,25,0), 0)) لا تنسى تحويل الفواصل حسب إصدار الأوفيس عندك

تفضل أخي الفاضل ملفين أحدهما معادلات و الآخر أكواد. اختر ما يحلو لك.
 
ناجح-راسب.xlsm ناجح-راسب.xlsx

و عليكم السلام ورحمة الله و بركاته
نعم، يمكنك طباعة الـ UserForm  في Excel باستخدام  VBA، ولكن يجب أولاً تحويل اليوزر فورم إلى صورة (Bitmap) ثم إرسالها إلى ورقة عمل أو كائن للطباعة. للأسف، الـ VBA لا يدعم طباعة اليوزر فورم مباشرة مثل ورقة العمل. يفضل ارفاق ملف لتوضيح المطلوب.
وبعد البحث في منتديات أوفيسنا وجدت الحل و قمت بالتعديل في الكود
رابط الملف الأصلي
https://www.officena.net/ib/topic/103266-معاينة-الطباعة-على-اليوزر-فورم/#google_vignette
و إليك الملف بعد التعديل
 
preview on userform.xlsm

و عليكم السلام ورحمة الله و بركاته
تفضل
نقل البيانات من عمود لاخر(2).xlsx

الله يحيك
تفضل ملفين الأول بالمعادلات و الثاني بالكود
مجموع المدة كاوقات.xlsx مجموع المدة كاوقات.xlsm

و عليكم السلام ورحمة الله و بركاته
تفضل الملف
تجربة ايجارات (2).xlsx