hegazee

الكود موجود باليوزرفورم من البداية
فقط قم بسحب شريط التمرير الأفقي الموجود بالأسفل
 

أخي الكريم
سبب المشكلة بالتفصيل:
تفعيل خيار "عرض الصيغ" (Show Formulas): ورقة العمل تحتوي على إعداد داخلي (showFormulas="1") يقوم بإظهار القيم الرقمية الخام للتواريخ (مثل 41604) بدلاً من التاريخ المنسق (2013/11/26)، مهما حاولت تغيير التنسيق. تجميد الصفوف: وجود صفوف مجمدة (حتى الصف 😎 قد يجعل التنقل وتغيير الإعدادات لبعض الأعمدة يبدو وكأنه لا يستجيب بشكل طبيعي. التنسيق المخصص: العمود G يستخدم تنسيقاً مخصصاً (yyyy/mm/dd) وهو صحيح، لكنه لا يظهر بسبب النقطة الأولى. كيفية حل المشكلة في ملفك الأصلي:
يمكنك حل المشكلة بضغطة زر واحدة :
اذهب إلى تبويب صيغ (Formulas) في شريط الأدوات العلوي. في مجموعة تدقيق الصيغ (Formula Auditing)، ستجد خيار إظهار الصيغ (Show Formulas) مفعلاً، قم بالضغط عليه لإلغاء تفعيله. أو استخدم اختصار لوحة المفاتيح: Ctrl + ~ )مفتاح حرف الذال في الكيبورد العربي(. بمجرد إلغاء هذا الخيار، ستظهر جميع التواريخ في العمود G بتنسيقها الصحيح فوراً. سبب نجاح الحل عند النسخ لملف جديد هو أن هذا الإعداد خاص بورقة العمل الحالية ولا ينتقل عند نسخ البيانات فقط إلى ملف جديد.
الصورة المرفقة من عندي أوفيس 365
 
 

تفضل الملف
حساب الفئة العمرية2.xlsx

تفضل
مجزر دواجن معدل.2.xlsx

تفضل
 
حساب_التاريخ3.xlsx

تفضل
ترتيب درجات الطلاب لمواد مختلفة(3).xlsx

و عليكم السلام ورحمة الله وبركاته
__اصناف مشتريات - نسخة2.xlsx

و عليكم السلام ورحمة الله وبركاته
 تفضل الملف بالأكواد. أما إذا كنت لا تفضل الأكواد فالحل بسيط وسهل باستخدام التصفية في العمود  الموجود به الحاله 
حذف و إظهار صف بشرط.xlsm

و عليكم السلام ورحمة الله و بركاته
الموضوع سهل جدا من خلال عمل فلترة الموجودة في اكسيل كما هو واضح بالصور. ممكن تستخدم أيا من الملفين واحد بالأكواد و الثاني بالصيغ بس لا يصلح إلا أوفيس 365 أو 2021
 

فلترة.7z

توزيع رقم على خلايا.xlsm

تفضل الملف باستخدام الصيغ مع عمل تنسيق شرطي للتأكد من التكرار
كشاف دخول اللجان2.xlsm

ممكن يكون طلبك هنا
https://www.youtube.com/watch?v=M1DhpzkT8kA
 او جرب هذا الكود:
Sub Observer_FullSystem() Dim ws As Worksheet, wsReport As Worksheet Dim NamesArr() As Variant Dim UsedRow As Object, UsedCol As Object, UsedAll As Object Dim lrNames As Long, lrRows As Long, lrCols As Long Dim r As Long, c As Long, i As Long Dim Available() As String Dim cnt As Long, MaxAllowed As Long, TotalCells As Long Dim TryCount As Long Dim MainCols As Long: MainCols = 2 ' عدد الأعمدة الأساسية Set ws = ActiveSheet Application.ScreenUpdating = False Randomize ' ===== Backup ===== ws.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Backup_" & Format(Now, "ddmmyy_hhmmss") ws.Activate ' ===== قراءة الأسماء ===== lrNames = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row NamesArr = ws.Range("B3:B" & lrNames).Value ' ===== حدود الجدول ===== lrRows = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row lrCols = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)).ClearContents ' ===== الحد الأقصى ===== TotalCells = (lrRows - 2) * (lrCols - 3) MaxAllowed = Application.WorksheetFunction.RoundUp(TotalCells / (lrNames - 2), 0) Set UsedAll = CreateObject("Scripting.Dictionary") ' ===== التوزيع ===== For r = 3 To lrRows Set UsedRow = CreateObject("Scripting.Dictionary") For c = 4 To lrCols TryCount = 0 RetryCell: TryCount = TryCount + 1 If TryCount > 300 Then GoTo NextCell Set UsedCol = CreateObject("Scripting.Dictionary") For i = 3 To r - 1 If ws.Cells(i, c).Value <> "" Then UsedCol(ws.Cells(i, c).Value) = 1 Next i cnt = 0 ReDim Available(1 To UBound(NamesArr, 1)) For i = 1 To UBound(NamesArr, 1) If Not UsedRow.exists(NamesArr(i, 1)) _ And Not UsedCol.exists(NamesArr(i, 1)) Then If Not UsedAll.exists(NamesArr(i, 1)) _ Or UsedAll(NamesArr(i, 1)) < MaxAllowed Then cnt = cnt + 1 Available(cnt) = NamesArr(i, 1) End If End If Next i If cnt > 0 Then ws.Cells(r, c).Value = Available(Int(Rnd * cnt) + 1) UsedRow(ws.Cells(r, c).Value) = 1 UsedAll(ws.Cells(r, c).Value) = UsedAll(ws.Cells(r, c).Value) + 1 Else GoTo RetryCell End If NextCell: Next c Next r ' ===== تقرير ===== On Error Resume Next Set wsReport = Sheets("تقرير") On Error GoTo 0 If wsReport Is Nothing Then Set wsReport = Sheets.Add wsReport.Name = "تقرير" Else wsReport.Cells.Clear End If wsReport.Range("A1:D1") = Array("الاسم", "الإجمالي", "أساسي", "احتياطي") For i = 3 To lrNames wsReport.Cells(i - 2, 1) = ws.Cells(i, 2) wsReport.Cells(i - 2, 2) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 3) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, 3 + MainCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 4) = wsReport.Cells(i - 2, 2) - wsReport.Cells(i - 2, 3) Next i wsReport.Columns.AutoFit Application.ScreenUpdating = True MsgBox "تم التوزيع + إنشاء نسخة احتياطية + تقرير كامل ?", vbInformation End Sub  

تفضل
Sub ToggleColumns() Dim action As String Dim colsInput As String Dim colArray() As String Dim colItem As Variant Dim answer As VbMsgBoxResult Dim invalidInput As Boolean ' مربع حوار لتحديد الإجراء (إخفاء أو إظهار) answer = MsgBox("هل تريد إخفاء الأعمدة؟" & vbCrLf & vbCrLf & "اضغط 'Yes' للإخفاء، 'No' للإظهار.", vbYesNoCancel + vbQuestion, "تحديد الإجراء") If answer = vbCancel Then Exit Sub ' الخروج إذا ضغط المستخدم على "Cancel" ElseIf answer = vbYes Then action = "إخفاء" Else action = "إظهار" End If ' مربع إدخال لطلب الأعمدة من المستخدم colsInput = InputBox("الرجاء إدخال الأعمدة التي تريد " & action & "ها." & vbCrLf & vbCrLf & "أمثلة:" & vbCrLf & "عمود واحد: B" & vbCrLf & "أعمدة متجاورة: B:D" & vbCrLf & "أعمدة متفرقة: B,D,F", "تحديد الأعمدة") ' الخروج إذا كان الإدخال فارغًا If colsInput = "" Then Exit Sub ' إزالة أي مسافات زائدة وتقسيم الإدخال عند الفاصلة colArray = Split(Replace(colsInput, " ", ""), ",") invalidInput = False On Error Resume Next ' تجاهل الأخطاء مؤقتًا للتحقق من صحة الإدخال ' المرور على كل عنصر أدخله المستخدم For Each colItem In colArray If colItem <> "" Then ' التحقق من أن كل جزء من الإدخال يمثل نطاقًا صالحًا If Columns(colItem).Count = 0 Then invalidInput = True Exit For End If End If Next colItem On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' إذا كان هناك إدخال غير صالح، أظهر رسالة خطأ If invalidInput Then MsgBox "الإدخال '" & colItem & "' غير صالح. الرجاء التأكد من إدخال أسماء أعمدة صحيحة.", vbCritical, "خطأ في الإدخال" Exit Sub End If ' تنفيذ الإجراء على كل عمود أو نطاق For Each colItem In colArray If colItem <> "" Then If action = "إخفاء" Then Columns(colItem).Hidden = True Else Columns(colItem).Hidden = False End If End If Next colItem MsgBox "تم " & action & " الأعمدة بنجاح!", vbInformation, "اكتمل الإجراء" End Sub  

و عليكم السلام ورحمة الله و بركاته
تفضل الحل بطريقتين الأول خاصة بنسخ الأوفيس الحديثة و الثانية بالنسخ القديمة
Base des donnes (2).xlsx

و عليكم السلام ورحمة الله وبركاته
إليك المطلوب  بصوت الشيخ المنشاوي رحمه الله مع تطوير و تحسين الملف. فقط تأكد وضع الملف الصوتي في نفس مجلد ملف الاكسيل و أرجو تعديل العنوان ليكون إضافة الفاتحة بدلا من الموسيقى  

crono.rar

و عليكم السلام ورحمة الله و بركاته
انشيء ملف جديد و وأضبطه كما تريد من حيث الحجم و الهوامش و كل شيء بعدين احفظ الملف  باسم مثلا A4 وبصيغة
 Excel Template (*.xltx)
الحفظ يكون في المسار التالي
C:\Users\[اسم المستخدم]\Documents\Custom Office Templates
لما تنشئ ملف جديد اختار القالب اللي أنت عملته اللي هو A4

لو عندك اكسيل حديث 365 مثلا يمكن استعمال الصيغة التالية
=TEXTJOIN("",TRUE,القرار!AM24:AM39,القرار!AN24:AN39) و يمكن بالأكواد مع الاصدارات القديمة و ده يلزم وجود ملف عشان نتأكد من النتيجة

بارك الله فيك أستاذ أحمد
. كما تفضلت حضرتك بالملف فإن معادلة العلامة خبور رائعة و تصلح لهذا الملف تماما فقط قم بنسخ الكود التالي في موديل جديد في  في محرر الأكواد
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