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

الأخ الكريم علي حسن ما هكذا يتم طرح الموضوعات .. لمزيد من المعلومات يمكنك الإطلاع على رابط التوجيهات في الموضوعات المثبتة إليك الملف التالي عله يكون المطلوب ..تم العمل على ورقة العمل Sheet2 قم بالضغط على زر الأمر لتنفيذ الكود Sub RunTest() Dim LR As Long, Rng As Range Application.ScreenUpdating = False Application.DisplayAlerts = False With Sheets("Sheet2") LR = .Cells(Rows.Count, 1).End(xlUp).Row Set Rng = .Range("A1:C" & LR) .Columns("F").ColumnWidth = .Columns("A").ColumnWidth .Columns("G").ColumnWidth = .Columns("B").ColumnWidth .Columns("H").ColumnWidth = .Columns("C").ColumnWidth Sheets.Add After:=Sheets(Sheets.Count) Rng.Copy ActiveSheet.Range("A1") End With With ActiveSheet.Range("D2:D" & LR) .Formula = "=SUMPRODUCT(($A$2:$A$" & LR & "=A2)*($B$2:$B$" & LR & "=B2)*($C$2:$C$" & LR & "))": .Value = .Value .Offset(0, -1).Value = .Value End With With ActiveSheet .Range("A1:C" & LR).RemoveDuplicates Columns:=VBA.Array(1, 2, 3), Header:=xlYes .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Sheet2").Range("F1") .Delete End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub أرجو أن يكون المطلوب Remove Duplicates For Summary Report.rar

أخي الكريم محمد الزريعي الحمد لله أن تم المطلوب على خير .. بارك الله فيك على التوضيح والتفكير بصوت عالي ، وأي شيء تحت أمرك في توضيحه وتفصيله أخيراً يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ... ويا ريت تقوم بالإطلاع على رابط التوجيهات في الموضوعات المثبتة

جرب تعديل الكود بهذا الشكل .. Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Reset_EnableEvents Application.ScreenUpdating = False Application.EnableEvents = False If Not Intersect(Target, Range("C18:C2014")) Is Nothing Then If IsEmpty(Target) Then Target = "" ElseIf Target.Value = 1 Then Target.Value = "اولي ابتدائي" ElseIf Target.Value = 2 Then Target.Value = "ثانية ابتدائي" ElseIf Target.Value = 3 Then Target.Value = "ثالثة ابتدائي" ElseIf Target.Value = 4 Then Target.Value = "الصف الرابع" ElseIf Target.Value = 5 Then Target.Value = "الصف الخامس" ElseIf Target.Value = 6 Then Target.Value = "الصف السادس" ElseIf Target.Value = 7 Then Target.Value = "الصف السابع" ElseIf Target.Value = 8 Then Target.Value = "الصف الثامن" ElseIf Target.Value = 9 Then Target.Value = "الصف التاسع" End If End If If Not Intersect(Target, Range("D18:D2014")) Is Nothing Then Select Case Target Case "ك" Target = "ذكر" Case "ن" Target = "انثى" End Select End If Application.ScreenUpdating = False If Target.Column = 4 Or Target.Column > 8 Then GoTo Reset_EnableEvents LR = Cells(Rows.Count, 2).End(xlUp).Row If Range("B" & LR) = "" Or Range("C" & LR) = "" Or Range("D" & LR) = "" Or Range("E" & LR) = "" Then GoTo Reset_EnableEvents Range("B18:E" & LR).Select Selection.Sort Key1:=Range("b18"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal ''''''''''''''''''''''''''''''''''''''''''''''' With Range("b18:b" & LR + 3) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True End With '''''''''''''''''''''''''''''''''''''''''''' With Range("B18:B" & LR + 3) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True End With Range("B" & LR + 5).Select Reset_EnableEvents: Application.ScreenUpdating = True Application.EnableEvents = True End Sub

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

ما إحنا قلنا عايزين نبعد عن الحلقات التكرارية .. يمكن عمل المطلوب بسطر واحد فقط .... غداً نلتقي لأنه موعد النوم ... أستودعك الله

موضوع المصفوفات أنا نفسي مبتديء فيه والله ..بس عشان أتعلم بفكر بصوت عالي ومعاً نرتقي سوياً ونتعلم سوياً في انتظار مساهماتك في موضوع المصفوفات

أخي الغالي أبو يوسف إن شاء الله تتابع معانا ..مشكور على مرورك العطر .. حاول تبدأ معانا بأي شكل .. يهمني تواجدك معانا بالموضوع وبالدراسة أخي المتميز إبراهيم أبو ليلة ..الله ينور عليك هو دا الشغل وتمام وممكن تشيل رقم 7 لو عدد عناصر المصفوفة مجهول وتضع مكانها UBound(Arr) مش كدا ولا ايه .. بس بصراحة كل الحلول ممتازة لأنها كلها تخدم الموضوع .. إنت كدا اتعرفت على إزاي تشتغل على الحلقات التكرارية داخل المصفوفة .. وعرفت إزاي تضع قيم المصفوفة مرة واحدة في نطاق محدد .. نيجي بقا لسؤال تاني جميل .. عايزين نضع القيم في عمود واحد وليس في صف واحد يعني القيم توضع في النطاق من A1:A7 تقبل تحياتي ومشكور على متابعتك الممتازة للموضوع

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

بسم الله ما شاء الله عليك أخي الحبيب إبراهيم .. هو دا الشغل ولا بلاش أفكار جميلة جداً وتثري الموضوع بشكل كبير .. لكن ما زلت أصمم على عدم استخدام الحلقات التكرارية لتنفيذ المطلوب .. حيث يمكن بسطر واحد فقط عمل اللازم ... فكر شوية .. هسهل عليك الموضوع أكتر المصفوفة عبارة عن قيم زي ما اتعلمنا .. القيم دي بتكون بالظبط زي شكل الصف بمعنى إن قيم المصفوفة شبيهة بالصف فلما نقول إن المصفوفة لها 7 قيم يبقا كل قيمة في عمود في صف واحد ... هسهلها أكتر فيه خاصية اسمها Resize حاول تستغلها ..... تقبل تحياتي

جرب الكود بهذا الشكل .. Sub SortCustomList() Dim I As Long, J As Long, K As Long, LR As Long Dim Arr1, Arr2, ArrOut Arr1 = Array("دكتور", "ماجستير", "بكالوريوس", "دبلوم", "ثانوية عامة") Arr2 = Array("سعودي", "عربي", "غير عربي") ReDim ArrOut(0 To 14) For I = 0 To UBound(Arr1) For J = 0 To UBound(Arr2) ArrOut(K) = Arr1(I) & " " & Arr2(J) K = K + 1 Next J Next I LR = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False With Range("J7:J" & LR) .Formula = "=TRIM(H7) & "" "" & TRIM(F7)": .Value = .Value End With Application.AddCustomList ArrOut Range("A6:I" & LR).Sort Key1:=Range("J6:J" & LR), OrderCustom:=Application.CustomListCount + 1, Key2:=Range("I6:I" & LR), Order2:=xlDescending, Key3:=Range("B6:B" & LR), Order3:=xlAscending, Header:=xlYes Columns("J:J").Delete Application.DeleteCustomList Application.CustomListCount Application.ScreenUpdating = True End Sub

الاخ الغالي المتميز الرائع حسام عيسى بارك الله فيك وجزاك الله خير الجزاء على هذه التحفة الفنية الرائعة يبدو أنه برنامج في منتهى الروعة والجمال ولكني للأسف لن أستطيع النقد حيث أنني أجهل الأمور المحاسبية .. ولكني في نفس الوقت متأكد من خبرتك العالية والواسعة جعله الله في ميزان حسناتك يوم القيامة .. نبدأ على بركة الله مشوار الكسر .. تقبل التحدي !!!!!!!!!! (ولا أقولك مش مهم إنت حبيبنا بردو ونخاف على برنامجك) يسر الله لك كل عسير .. تقبل تحياتي

جرب الملف المرفق فيه تطبيق المعادلة التي لم تعمل معك Sumproduct.rar

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

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

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

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

السلام عليكم أخي الفاضل اعمل كليك يمين على ورقة العمل Sheet1 ثم اختر الأمر View Code والصق الكود التالي .. Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) Dim strSheet As String If InStr(Target.Parent, "!") > 0 Then strSheet = Left(Target.Parent, InStr(1, Target.Parent, "!") - 1) Else strSheet = Target.Parent End If On Error Resume Next Sheets(strSheet).Visible = True Sheets(strSheet).Select End Sub Private Sub Worksheet_Activate() Dim WS As Excel.Worksheet For Each WS In ThisWorkbook.Worksheets If WS.Name <> "المراجعه" Then WS.Visible = (WS.Name = Me.Name) End If Next End Sub تقبل تحياتي

جرب المعادلة التالية في الخلية G6 =SUMPRODUCT(--(MONTH($B$2:$B$12)=G4)*($A$2:$A$12=G5)) بفرض أن الخلية G4 بها رقم الشهر 7 مثلاً والخلية G5 بها كلمة جديد مثلاً

أخي الكريم يرجى تغيير اسم الظهور ليعبر عن شخصكم الكريم الحمد لله ان تم المطلوب على خير .. لم اطلع على المرفقات في مشاركتك السابقة ولكن يرجى ذكر الخطأ الذي بسببه لم يعمل الكود معك حتى يتعلم الجميع الاخطاء الشائعة في حالة عدم عمل الكود .. بارك الله فيك على دعائك الطيب تقبل تحياتي

وعليكم السلام ورحمة الله وبركاته أخي الحبيب عبد العزيز مشكور على مرورك العطر وإن شاء الله معاً سوياً خطوة بخطوة لفهم المصفوفات حيث أن هذا الموضوع هام جداً ومفيد للغاية في التعامل مع الأكواد .. الأخ الغالي إبراهيم أبو ليلة عوداً حميداً .. اشتقنا لك ولمشاركاتك القيمة وتسلم على الأداء العالي والمميز وبالمناسبة سأسأل سؤال متقدم على الشرح ... كيف نضع قيم المصفوفة في النطاق A1:G1 أي وضعها في الصف الأول لتكون القيمة sat في الخلية A1 وتكون القيمة sun في الخلية B1 وهكذا للقيم السبعة للمصفوفة ؟

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

قم بإرفاق ملفك للإطلاع عليه

إليك الكود التالي عله يفي بالغرض Sub VacationReport() 'يقوم الكود بعمل تقرير بأسماء الموظفين الذين زادت أيام الأجازات عن 4 أيام 'بفرض أن لكل موظف ورقة عمل وتبدأ أوراق عمل الموظفين من الورقة رقم 5 إلى 'آخر ورقة بالمصنف ، قم باختيار الشهر من ورقة العمل المراد عمل التقرير بها 'التي تحتوي على قائمة منسدلة بأسماء شهور السنة ثم نفذ الكود [B3] من الخلية '------------------------------------------------------------------------- 'الإعلان عن المتغيرات Dim WS As Worksheet, Str As String Dim I As Long, Found As Range Dim lRow As Long 'تعيين المتغير ليساوي ورقة تقرير الخصم Set WS = Sheets("تقرير خصم 5%") 'تعيين المتغير ليساوي اسم الشهر الموجود بالخلية Str = WS.Range("B3").Value 'رقم أول صف سيتم إدراج النتائج به lRow = 7 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'مسح محتويات النطاق الذي سيتم إدارج النتائج به WS.Range("A7:C1000").ClearContents 'حلقة تكرارية لأوراق العمل من الورقة رقم 5 إلى آخر ورقة عمل في المصنف For I = 5 To Sheets.Count 'سطر لايجاد النطاق الذي يحوي على اسم الشهر داخل ورقة العمل الخاصة بالموظف Set Found = Sheets(I).Columns("I:I").Find(Str) 'إذا وجد نتيجة للبحث عن اسم الشهر يتم تنفيذ الأسطر التالية If Not Found Is Nothing Then '[Found] إيجاد قيمة الخلية التي تقع في العمود السابق للمتغير '[H] أي أنها تجلب عدد إجمالي عدد أيام الأجازات من العمود 'فإذا كانت قيمة الخلية أكبر من أو يساوي 4 أيام يتم تنفيذ المطلوب وجلب البيانات If Found.Offset(0, -1) >= 4 Then 'في ورقة الموظف [B2] الخلية في الصف المحدد في ورقة التقرير في العمود الأول تساوي الخلية WS.Cells(lRow, 1) = Sheets(I).Range("B2") 'في ورقة الموظف [A1] الخلية في الصف المحدد في ورقة التقرير في العمود الثاني تساوي الخلية WS.Cells(lRow, 2) = Sheets(I).Range("A1") 'الخلية في الصف المحدد في ورقة التقرير في العمود الثالث تساوي قيمة الخلية 'التي تحتوي إجمالي الأجازات والتي تقع في العمود السابق للنطاق المتغير WS.Cells(lRow, 3) = Found.Offset(0, -1) 'زيادة قيمة الصف المحدد بمقدار واحد للانتقال إلى صف جديد لإدراج بيانات جديدة lRow = lRow + 1 End If End If Next I 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub

نعم يمكن ..اطرح موضوع جديد لتجد الإجابة على طلبك

أخي الغالي حسام مشكور على مرورك العطر .. إن شاء الله يكون كل يوم أو يومين جزئية جديدة لأن الموضوع كبير ومحتاج وقت أخي الحبيب بكار جزيت خيراً على مرورك الكريم وعلى ملف شرح معادلات الصفيف الموضوع يخص التعامل مع المصفوفات داخل محرر الأكواد وكنوع من المتابعةعشان نعرف مين اللي قرا الموضوع ودرسه كويس .. اكتب كود تقوم فيه بتخزين مصفوفة من 7 قيم على أن تبدأ الفهرسة من رقم 1 .. وقم بتخزين أيام الأسبوع .. وأظهر أول رقم وآخر رقم في الفهرس من خلال رسالة