ياسر خليل أبو البراء

أخي الكريم محمد الزريعي يفضل دائماً أن يكون الملف معبر عن الطلب ..لما لم تضع الملف كما وصفت في مشاركتك السابقة بشكل مباشر .. عموماً يرجى الإطلاع على التوجيهات لمعرفة كيفية التعامل مع المنتدى إليك الكود التالي وإن شاء المولى يفي بالغرض Sub SortCustomList() Dim I As Long, LR As Long, vArray() As Variant vArray = Array("دكتور", "ماجستير", "بكالوريوس", "دبلوم", "ثانوية عامة") LR = Cells(Rows.Count, 1).End(xlUp).Row Application.AddCustomList vArray Range("A6:K" & LR).Sort Key1:=Range("G6:G" & LR), OrderCustom:=Application.CustomListCount + 1, Header:=xlYes Application.DeleteCustomList Application.CustomListCount End Sub Sort Custom List YasserKhalil.rar

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

بسم الله ما شاء الله عليك أخي الحبيب سليم مبدع كعادتك دائماً ..تسلم على هذه الفكرة الجميلة

إخواني الكرام أعتذر عن التأخر في الرد على هذا الموضوع بالذات فقد ظهر لي أن الموضوع به مشاركة غير مقرؤءة فلما تصفحت الموضوع وجد آخر رد للأخ الحبيب ياسر فتحي وبعد ذلك بيوم تقريباً وجدت أن الموضوع غير مقروء بالنسبة لي ووجدت آخر مشاركة للأخ ياسر فتحي فبدا لي أن الأمر يتعلق بالموقع ومشاكله ولم ألاحظ إلا الآن أن هناك صفحة ثانية للموضوع (وهذه ميزة افتقدناها مع التحديث الجديد) لأنه في السابق كان هناك فهرس للصفحات في المنتدى فكان بالإمكان الانتقال لآخر صفحة بشكل مباسر ... والله زمان المهم مطولش عليكم قولوا إنت طولت خلاااااااااااص وخدت من وقتكم إليكم الحل التالي عله يفي بالغرض وينهي هذه المشكلة تماماً.. Private Sub Workbook_Open() 'إخفاء المعادلات عن طريق حماية ورقة العمل ، قم بتحديد كل خلايا الورقة '[Locked] كليك يمين ثم تنسيق خلايا وأزل علامة الصح بجانب الخيار المسمى 'حدد الخلايا المراد عمل حماية لها والتي تحتوي المعادلات المراد حمايتها '[Locked] كليك يمين عليها ثم تنسيق خلايا وضع علامة صح بجانب الخيار المسمى '[Protect Sheet] ثم الأمر [Review] قم بعمل حماية لورقة العمل من خلال التبويب 'قم بوضع الكود التالي في حدث المصنف لتتم الحماية عن طريق عدم تمكين المستخدم 'من اختيار أو تحديد الخلية المحمية وبذلك يتم حمايتها وإخفائها من العبث '--------------------------------------------------------------------------- Worksheets("Sheet1").EnableSelection = xlUnlockedCells End Sub هو السطر دا وبس وخلصت الحكاية

أعتقد ان المشكلة إذاً أنه لابد من إدخال البيانات المفروض إدخالها أولاً ..عموماً أطلب منك للمرة الثانية أن تقوم بملء البرنامج بالبياناات الرئيسية لكل الفصول بحيث يكون البرنامج مستوفي .. ثم تقوم بتجربة البرنامج بشكل جيد ..حاول دائماً أن تكون التجربة بنسخة احتياطيه وليست النسخة الأصلية ... اعمل زي ما بعمل أنا لما بحب أنفذ الكود مش بنفذه على الملف الأصلي مطلقاً ... باخد نسخة وأجرب عليها وأشوف الأخطاء وأصلحها في الملف الأصلي وأرجع أختبر الكود مرة تانية وتالتية وهكذا إلى أن يتم الأمر بصورة صحيحة .. يعني كل الملفات اللي برفعها لك تعتبر أصل أي أنه لم يتم تنفيذ الكود عليها مطلقاً جرب الملف التالي عله يفي بالغرض بالنسبة لطلبك الأخير Quran School V11.2.rar

وعليكم السلام أخي أبو عبد الملك هل غيرت شيء في البرنامج ...أو في أوراق العمل التي تم عليها العمل مسبقاً ....؟؟؟ يرجى مراجعة جميع الأوراق من البداية لأنه يوجد الآن خطأ يظهر معي في ورقة التقرير الشهري؟

ممكن توضيح بمثال تطبيقي ويا ريت تذكر الأسماء اللي عايز ترتب على أساسهم أنا عندي تقريباً الحل لكن لم تكتمل المعطيات بالنسبة لي شوية شرح بالتفصيل

يرجى مراجعة التوجيهات مع الشكر من هنا جرب الملف التالي إذا كنت تريد تطبيق المشروح في الرابط Auto Complete In Data Validation List.rar

أخي الكريم أبو عبد الملك إليك الملف التالي ... ولكن لي رجاء عندك حتى تتم الأمور على أكمل وجه لابد من وضع بياانات لكل الفصول ولكل الشهور حتى يتسنى لك اختبار الأكواد كما ينبغي لأن إصلاح الكود بيكون أصعب من كتابته جرب الملف وأعلمني بالنتيجة وأعلمني بنسبة الإنجاز .. وكبر حجم الخط تقبل تحياتي Quran School V11.1.rar

الحمد لله الذي بنعمته تتم الصالحات الحمد لله أن تم المطلوب على خير جزاك الله خيراً على دعائك الطيب المبارك أستأذنك في مراجعة التوجيهات لمعرفة كيفية التعامل مع المنتدى

الحمد لله الذي بنعمته تتم الصالحات يا ريت تبلغنا كم نسبة إنجاز المطلوب إلى الآن ؟ تقبل تحياتي

يمكنك تجربة المعادلة التالية علها تنهي الموضوع ... =MOD(DEGREES(ATAN(SUMPRODUCT(TAN(RADIANS(B2:E2))))), 360)

تفضل أخي الحبيب '=======Start======= 'هذه الأسطر لحساب متوسط السلوك في ورقة التقرير الفصلي X1 = Application.WorksheetFunction.SumIfs(rngSlook, rngNames, .Cells(I, "C"), rngMonth, strA) X2 = Application.WorksheetFunction.SumIfs(rngSlook, rngNames, .Cells(I, "C"), rngMonth, strB) X3 = Application.WorksheetFunction.SumIfs(rngSlook, rngNames, .Cells(I, "C"), rngMonth, strC) X4 = Application.WorksheetFunction.Sum(X1, X2, X3) / 3 XFinal = Application.WorksheetFunction.Round(X4, 2) .Cells(I, "E").Value = XFinal '========End======== وهذا الجزء الثاني للمخالفات '=======Start======= 'هذه الأسطر لحساب متوسط المخالفات في ورقة التقرير الفصلي X1 = Application.WorksheetFunction.SumIfs(rngMokhalef, rngNames, .Cells(I, "C"), rngMonth, strA) X2 = Application.WorksheetFunction.SumIfs(rngMokhalef, rngNames, .Cells(I, "C"), rngMonth, strB) X3 = Application.WorksheetFunction.SumIfs(rngMokhalef, rngNames, .Cells(I, "C"), rngMonth, strC) X4 = Application.WorksheetFunction.Sum(X1, X2, X3) / 3 XFinal = Application.WorksheetFunction.Round(X4, 2) .Cells(I, "R").Value = XFinal '========End======== وللعلم تم العمل على هذه الأعمدة من قبل بناءً على توضيح آخر لم يكن بهذا الشكل على ما أذكر عموماً .. يفضل دائماً أن تكون هناك نتائج مرفقة للمتوقع حتى يسهل علي اختبار الكود جرب الكود بعناية قبل الانتقال لنقطة جديدة .. Quran School V11.rar

أخي الكريم أبو لجين أين الملف المرفق .. بعد إعادة تحميل الصفحة لم أجد ملفك المرفق ؟

أخي الكريم أبو لجين إليك الدالة المعرفة التالية علها تفي بالغرض Function AnglesAverage(Rng As Range) Application.Volatile Dim Cell As Range, Counter As Long, Temp For Each Cell In Rng Temp = Temp + Tan(Cell.Value * Application.WorksheetFunction.PI() / 180) Next Cell Temp = Atn(Temp) * 180 / Application.WorksheetFunction.PI() If Temp <= 0 Then Temp = Temp + 360 AnglesAverage = Temp End Function

أخي الكريم أبو عبد الملك يرجى الإطلاع على الملف التالي والتحقق من النتائج تم إضافة هذه الأسطر '=======Start======= 'هذه الأسطر تقوم باستخراج بيانات عمود المنهج في ورقة التقرير الفصلي With Sheets("المنهج") LRCur = .Cells(Rows.Count, 1).End(xlUp).Row Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur) Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur) Set rngMnhg = .Range("A2:D1000") End With X = ValueLookUp(rngB, .Cells(I, "N").Value, rngC, rngD, .Cells(I, "O").Value, rngA) XX = Application.WorksheetFunction.VLookup(X + 29, rngMnhg, 2) YY = Application.WorksheetFunction.VLookup(X + 29, rngMnhg, 4) .Cells(I, "W") = XX & " " & YY '=======End======= إذا تم الأمر فيرجى إنهاء الموضوع بالشكل المناسب وطرح موضوع آخر بالطلب الجديد ولا تنسى أن تسجل إعجابك إذا أعجبك الحل تقبل تحياتي Quran School V10.6.rar

إذا كان الأمر قد تم فيرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي وتقبل توجيهات المنتدى

أعتقد أخي الكريم خالد أن هذه مشكلة فيروسات وإذا لم يكن الأمر كذلك يمكنك تنصيب نسخة أوفيس أخرى غير النسخة التي تعمل عليها

جرب الكود بهذا الشكل Sub ActivateCell() 'يمكن استخدام خاصية البحث عن كلمة محددة بهذا الشكل 'في الصف الثالث [Loading Dates] لنفترض أن لديك النص 'يمكن استخدام خاصية البحث لتحديد الخلية التي تحتوي على النص '----------------------------------------------------------- Dim Rng As Range On Error Resume Next Set Rng = Rows(3).Find("Loading Dates") Rng.Activate On Error GoTo 0 End Sub

اخي الكريم سليم يمكنك تغيير البيانات في ورقة العمل Data كما تريد وبعد التغيير يتم تنفيذ الكود ..غير وبدل ونفذ الكود وشوف النتائج !! أما بالنسبة لورقة العمل المسماة النتيجة فيمكن حذفها ويمكن حذف ورقة العمل المسماة Final أيضاً إذ أن الكود يقوم بإنشاءها مع كل تنفيذ للكود أي أن الأوراق المطلوبة فقط ورقة العمل Data والورقة الثانية التي بها شروط التصفية "ادخال وسيط" .. تقبل تحياتي

أخي الكريم أبو عبد الملك يراعى الالتزام بالتوجيهات (عيني وجعتني من الخط الصغير ...) إليك السطر التالي يؤدي الغرض .Cells(I, "V") = Level(.Cells(I, "T")) Quran School V10.5.rar

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

أخي الكريم سليم يرجى أن يكون اسم الظهور بشكل ثنائي حتى يعرف الأعضاء فهناك الأخ سليم حاصبيا والآن سليم. أرجو منك رفع الموضوعات التي تم فيها طرح الطلب والمطالبة بحذفها منعاً لتكرار الموضوعات وللأهمية قم بالإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدى ( من هنا ) جرب الملف التالي عله يفي بالغرض تم تغيير اسم ورقة "استيراد البياناتط إلى Data .. والنتائج ستظهر في ورقة عمل منفصلة باسم Final كما تم عمل عمود مساعد لاستخراج بيانات العمود المسمى المستودع باسم المستودع2 Function RemoveSpecial(T As String) Dim I As Long, NewString As String For I = 1 To Len(T) If Not IsNumeric(Mid(T, I, 1)) Then NewString = NewString & Mid(T, I, 1) End If Next I RemoveSpecial = Trim(Replace(Replace(Replace(Replace(NewString, "م ", ""), "م.", ""), " م", ""), "-", "")) End Function Sub Test() Dim arrFilter, arrTemp, strFilter As String, strRange As String, I As Long, J As Long, V As Variant Dim pivItem As PivotItem, wsOutput As Worksheet Application.ScreenUpdating = False On Error Resume Next Set wsOutput = Sheets("Final") If Err Then Set wsOutput = Worksheets.Add(after:=Worksheets(Worksheets.Count)) wsOutput.Name = "Final" End If On Error GoTo 0 wsOutput.Cells.Clear arrFilter = Sheets("ادخال الوسيط").Range("A2").CurrentRegion.Offset(1).Value For I = 1 To UBound(arrFilter, 1) For J = 1 To UBound(arrFilter, 2) If arrFilter(I, J) <> "" Then V = Split(arrFilter(I, J), "*") strFilter = strFilter & Chr(2) & Application.Min(V(0), V(1)) & "*" & Application.Max(V(0), V(1)) End If Next J Next I With Sheets("Data") strRange = .Name & "!" & .Range("A4:H" & .Cells(.Rows.Count, "A").End(xlUp).Row).Address End With ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=strRange).CreatePivotTable TableDestination:="", TableName:="tempPivotTable", DefaultVersion:=xlPivotTableVersion10 With ActiveSheet .PivotTableWizard TableDestination:=.Cells(3, 1) .Cells(3, 1).Select .PivotTables("tempPivotTable").AddFields RowFields:=Array("القياس", "اسم المادة", "رمز المادة"), ColumnFields:="المستودع2" With .PivotTables("tempPivotTable") With .PivotFields("الكمية") .Orientation = xlDataField .Caption = "إجمالي الكمية" .Function = xlSum End With .PivotFields("اسم المادة").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False) For Each pivItem In .PivotFields("القياس").PivotItems If InStr(1, strFilter, Chr(2) & pivItem.Name) = 0 Then pivItem.Visible = False Next pivItem End With .Cells.Copy wsOutput.Range("A1").PasteSpecial (xlPasteValues) wsOutput.Range("A1").PasteSpecial (xlPasteFormats) Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With With wsOutput .Rows("2:3").Delete xlShiftUp .Rows("2").HorizontalAlignment = xlCenter .Cells.Replace "Grand Total", "الإجمالى الكلى" .Cells.Replace "Total", "الإجمالى" .UsedRange.Columns.AutoFit With .Range("A2").CurrentRegion With .Columns("A").Cells arrTemp = .Value For I = 2 To UBound(arrTemp, 1) If arrTemp(I, 1) = "" Then arrTemp(I, 1) = arrTemp(I - 1, 1) Next I .Value = arrTemp End With With .Borders .LineStyle = xlContinuous .Weight = xlThin End With .AutoFilter Field:=1, Criteria1:="*الإجمالى*" With .SpecialCells(xlCellTypeVisible).Interior .ColorIndex = 48 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With End With .AutoFilterMode = False .Select .Range("A1").Select End With Application.ScreenUpdating = True End Sub جرب الملف وأعلمنا بالنتيجة تقبل وافر تقديري واحترامي Detailed Inventory YasserKhalil.rar

أخي الكريم ياسر أحمد راجع رابط التوجيهات على هذا الرابط من هنا

أخي الكريم أبو عبد الملك موضوع الترتيب بالذات لابد من إرفاق النتائج المتوقعة فيه .. لو لديك معادلة للترتيب تريد تطبيقها يرجى إرفاقها ..لأن موضوع الترتيب يكون على أكثر من شرط في بعض الأحيان على العموم جرب الملف التالي .. ولا تنسى أن تحدد أفضل إجابة وتنهي الموضوع في حالة أن تم المطلوب Quran School V10.rar