hegazee

أعتذر لك لضيق وقتي. لعل أحد الأاساتذه يفيدك لأن المطلوب يستغرق وقت

ثانوية عامة2.xlsm

فعلا أخي هذا سلوك معروف في Excel. السبب الحقيقي ليس الإعدادات عند استخدام التصفية المخصصة Custom Filter على عمود تاريخ: Excel يتجاهل تنسيق الخلية تمامًا ويقرأ التاريخ من نظام ويندوز مباشرة ثم يعرض أسماء الشهور حسب تقويم النظام (هجري) لذلك: الخلية = يناير (ميلادي) التصفية = محرم (هجري) وهذا Bug قديم في Excel العربي.

من الواضح أن المشكلة عندك من إعدادات اللغة في جهازك و هذه صورة من الملف عند تشغيله عندي

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

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

و عليكم السلام ورحمة الله وبركاته برجاء ارفاق الملف لنتبين هل المشكلة من عندك أم من الملف.

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

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

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

تفضل الملف باستخدام الصيغ مع عمل تنسيق شرطي للتأكد من التكرار كشاف دخول اللجان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

أضغط عل اسم الصنف هنا أو أكتب أول حرف