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

الأخ الكريم أحمد إثراءً للموضوع إليك الكود التالي ..قم بالضغط على زر الأمر "قل : الحمد لله" في ورقة العمل الثانية لتظهر لك النتائج تقريباً كما أرفقتها في المشاركة الأولى .. Option Explicit Sub ExtractExistingNonExisting() Dim Coll As New Collection, Arr1, Arr2, ArrOut(), Str1 As String Dim pDup As Long, pUniq As Long, I As Long, P As Long With Sheets("Sheet1") Arr1 = .Range("A1").CurrentRegion.Value Arr2 = .Range("D1").CurrentRegion.Value End With ReDim ArrOut(1 To (UBound(Arr1, 1) + UBound(Arr2, 1)), 1 To 8) On Error Resume Next For I = 1 To UBound(Arr2, 1) Coll.Add Key:=CStr(Arr2(I, 1)), Item:=I Next I On Error GoTo 0 For I = 1 To UBound(Arr1, 1) On Error Resume Next Str1 = CStr(Arr1(I, 1)) P = Coll(Str1) If Err Then pUniq = pUniq + 1 ArrOut(pUniq, 7) = Arr1(I, 1) ArrOut(pUniq, 8) = Arr1(I, 2) Else pDup = pDup + 1 ArrOut(pDup, 1) = Arr1(I, 1) ArrOut(pDup, 2) = Arr1(I, 2) ArrOut(pDup, 4) = Arr2(P, 1) ArrOut(pDup, 5) = Arr2(P, 2) Coll.Remove (Str1) End If On Error GoTo 0 Next I For I = 1 To Coll.Count P = Coll(I) pUniq = pUniq + 1 ArrOut(pUniq, 7) = Arr2(P, 1) ArrOut(pUniq, 8) = Arr2(P, 2) Next I Sheets("Sheet2").Range("A1").Resize(UBound(ArrOut, 1), UBound(ArrOut, 2)).Value = ArrOut End Sub Extract Existing Non-Existing From Two Lists YasserKhalil.rar

طيب وقيمة اليوم كيف يتم احتسابها ..بقسمة الأساسي على 30 يوم ولا 31 يوم ولا 28 يوم اعذرني لجهلي بالأمور المالية وضح ويا ريت لو فيه مثال تطبيقي بالأرقام وما هي الخلايا التي تريد فيها المعادلات؟

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

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

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

أخي الكريم أشرف قلت لك اللي يطارد عصفورين يفقدهما فتحت موضوعين بطلبين ..شيء جميل لكن أفضل طالما إن العمل على ملف واحد يبقا طلب طلب .عشان تبني الطلب اللي جاي على الملف ده عموماً اتفضل الملف التالي وشوف النتائج بشكل جيد وتفحص الملف جيداً .. حتى إذا اطمأن قلبك قم بإرفاق الملف الجديد في الموضوع الجديد بالطلب الجديد يا أستاذ سعيد .. تقبل تحياتي Export Workbooks Using Filter Method V1.rar

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

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

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

ببساطة شيل المرجع A1 من المعادلة دي =MROUND(A1;10) وضع مكانها المعادلة المرجوة بدون علامة يساوي U4/100)*40 )

أخي الكريم إبراهيم السؤال الأول إجابته نعم هو البارامتر الاول (النص أو الشرط الذي يتم اختيار عناصر القائمة على أساسه) السؤال الثاني .. كلامي صحيح والدليل الملف المرفق ..جرب الملف المرفق قمت بحذف الثلاثة سطور واكتفيت بسطر واحد فقط دول الـ 3 سطور If Not Dic.exists(Dn.Value) Then Dic(Dn.Value) = Empty End If يبدو أنه قد حصل لبس في الأمر Add Unique Items In ComboBoxes YasserKhalil.rar

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

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

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

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

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

كل اللي بتسأل عليه موجود في سطر واحد فقط ألا وهو سطر الاستدعاء Call cValues(ComboBox1.Value, ComboBox2, 2) أنا قلت إن الإجراء شبه الدوال المعرفة UDF Functions .. يعني ليها بارامترات ..البارامتر الأول هنا هو النص أو الشرط وهو هنا في المثال قيمة الكومبو الأول البارامتر الثاني هو الكائن المستهدف obj الذي نريد تعبئة بياناته والبارامتر الثالث هو رقم العمود اللي هنجيب منه بيانات الكومبو الجديد يا ريت تكون وضحت الصورة ..

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

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

أخي الحبيب إبراهيم كنت فتحت موضوع مستقل يكون أفضل ليستفيد أكبر قدر من الأعضاء ركز على الاستخدام الأول شوف الجزء ده .. Private Sub ComboBox1_Click() Call cValues(ComboBox1.Value, ComboBox2, 2) End Sub هنا بمجرد إنك تختار عنصر من قائمة الكومبو الأول يتم تنفيذ السطر الموجود وهو عبارة عن .. عملية استدعاء (ربنا يكفينا شرهم) والإجراء دا مختلف عن الماكرو العادي وشبيه بالدوال المعرفة ، يعني زي ما الدوال ليها بارامترات ، الإجراء ده له بارامترات ... هنا فيه 3 بارامترات : الأول النص المراد البحث عنه ، والثاني الكائن (الكومبو) اللي هيتم تعبئته بالقيم الفريدة الخاصة بالنص ، والثالث رقم العمود الهدف اللي هييجي منه القيم كما في المرفق عند اختيار مثلاً فاتورة بيع من الكومبو الأول يتم تنفيذ الإجراء وتتم عملية الاستدعاء لقيمة الكومبو الأول (فاتورة بيع) ويبدأ الكود يعبي الكومبو الثاني بناءً على القيم الغير مكررة من العمود الثاني (أسماء العملاء) *************** نروح للإجراء الشبيه بالدالة المعرفة تعريف المتغيرات يليه هذا السطر Obj.Clear المقصود بالكائن هنا الكومبو الهدف (المراد تعبئته بالقيم الفريدة) ..والسطر بيمسح العناصر الموجودة لتتم عملية التعبئة على نضافة السطر التالي With WS Set Rng = .Range(.Cells(4, Col), .Cells(Rows.Count, Col).End(xlUp)) End With المتغير WS لأنه مستخدم في أكتر من مكان (الخاص بتعيين ورقة العمل المسماة "اليومية") فضلت إنه يكون متغير عام Public فوضعت السطر التالي في موديول Public WS As Worksheet عشان كل الموديولات الموجودة تشوف المتغير وتتعامل معاه .. ولكن أين يتم تعيين المتغير ؟؟ إحنا أعلنا عنه لكن بيمثل ايه بالظبط .. روح لحدث فتح المصنف ستجد الكود التالي Private Sub Workbook_Open() Set WS = Sheets("اليومية") End Sub أي مع فتح المصنف يتم تعيين المتغير ليساوي ورقة العمل "اليومية" يرجع مرجوعنا لموضوعنا Set Rng = .Range(.Cells(4, Col), .Cells(Rows.Count, Col).End(xlUp)) تعيين النطاق ليساوي العمود الهدف (البارامتر الثالث) بداية من الصف الرابع في البيانات إلى آخر صف في نفس العمود ************* أرتاح شوية ********** أصلي بتعب من الكتابة ********** (هو الجو حر ولا مصر دخلت النار .. ربنا يلطف بينا) رجعنا Back Set Dic = CreateObject("Scripting.Dictionary") السطر ده شرحناه قبل كدا ..تعيين المتغير Dic من النوع كائن (ليمثل الكائن قاموس) وعرفنا فايدته لتخزين القيم الفريدة أي الغير مكررة Dic.CompareMode = 1 السطر ده تم شرحه في المشاركة السابقة زي السطر ده (هو هو) Dic.CompareMode = vbTextCompare ننتقل لأهم جزئية :::: For Each Dn In Rng If Dn.Offset(, -1).Value = Txt Then If Not Dic.exists(Dn.Value) Then Dic(Dn.Value) = Empty End If End If Next Dn الجزء ده لازم يتشرح لوكشة واحدة لأنه حلقة تكرارية .. في كل خلية من خلايا النطاق (العمودالهدف اللي بييجي منه القيم الفريدة) هنا القيم بتيجي مثلاً من العمود الثاني (أنا بضرب مثال تطبيقي) بناءً على العمود الأول فبنقول كدا If Dn.Offset(, -1).Value = Txt Then لو قيمة الخلية في العمود الأول (الذي يسبق العمود الثاني ولذلك وضعنا -1) تساوي النص (اللي بيعتبر شرط لإكمال المهمة) ..الشرط مثلاً "فاتورة بيع" فلو كانت قيمة الخلية في العمود الأول تساوي "فاتورة بيع" يكمل باقي الأسطر أما إذا لم يتحقق الشرط ينتقل للخلية التالية من خلايا العمود الثاني لو تحقق الشرط وهو دا المهم يعمل ايه الكود يبدأ ياخد قيم العمود الهدف (العمود الثاني على سبيل المثال في مثالنا) ويخزنه في القاموس والجزء ده شرحناه في المشاركة السابقة If Not Dic.exists(Dn.Value) Then Dic(Dn.Value) = Empty End If الجزء دا يعني لو قيمة الخلية مش موجودة اتفضل وضيفها للقاموس .. وعلى فكرة يمكن الاستغناء عن الثلاثة أسطر (لأن من خواص القاموس إنه بيخزن القيم الفريدة تلقائي) فمفيش داعي للشرط ده وممكن نستبدلهم بسطر واحد Dic(Dn.Value) = Empty آخر جزئية هي وضع مفاتيح القاموس في الكومبو Obj.List = Application.Transpose(Dic.keys) تقبلوا تحياتي

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

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

جرب الكود بهذا الشكل Sub فحص() On Error Resume Next Set ww = Application.WorksheetFunction LastRow = Cells(Rows.Count, "B").End(xlUp).Row Application.ScreenUpdating = False Range("A6:A" & LastRow).ClearContents Range(Cells(6, 10), Cells(1000, 10)).ClearContents For R = LastRow To 6 Step -1 If Cells(R, 2).Value = Range("H2").Value Then If ww.CountIf(Range("B6:B" & R), Cells(R, 2).Value) > 1 Then Cells(1000, 10).End(xlUp).Offset(1, 0) = Cells(R, 2) Range(Cells(R, 2), Cells(R, 15)).EntireRow.Delete End If End If Next Range("B6:O1000").Sort [B5], xlAscending For N = 6 To LastRow If Cells(N, 2) <> "" Then Cells(N, 1) = Cells(N, 2).Row - 5 End If Next Application.ScreenUpdating = True Cells(6, 10).Select On Error GoTo 0 End Sub

جرب التعديل البسيط Sub فحص() On Error Resume Next Set ww = Application.WorksheetFunction LastRow = Cells(Rows.Count, "B").End(xlUp).Row Application.ScreenUpdating = False Range("A6:A" & LastRow).ClearContents Range(Cells(6, 10), Cells(1000, 10)).ClearContents For R = 6 To LastRow If ww.CountIf(Range("B6:B" & R), Cells(R, 2).Value) > 1 Then Cells(1000, 10).End(xlUp).Offset(1, 0) = Cells(R, 2) Range(Cells(R, 2), Cells(R, 15)).EntireRow.Delete End If Next Range("B6:O1000").Sort [B5], xlAscending For N = 6 To LastRow If Cells(N, 2) <> "" Then Cells(N, 1) = Cells(N, 2).Row - 5 End If Next Application.ScreenUpdating = True Cells(6, 10).Select On Error GoTo 0 End Sub

إليك الملف بعد تطبيق المعادلة الصف الاول الثانوي بنين- 2015.rar